]> Git — Sourcephile - haskell/literate-web.git/blob - src/Literate/Web/Semantics/Server.hs
feat(live): init `Literate.Web.Live`
[haskell/literate-web.git] / src / Literate / Web / Semantics / Server.hs
1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE StandaloneDeriving #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 {-# OPTIONS_GHC -Wno-orphans #-}
5
6 module Literate.Web.Semantics.Server where
7
8 -- import Data.Text.Lazy qualified as TextL
9 -- import Data.Text.Lazy.Encoding qualified as TextL
10 -- import Network.Wai qualified as Wai
11 -- import Prelude (undefined)
12 -- import Data.Text.Encoding qualified as Text
13 import Control.Applicative (Applicative (..))
14 import Control.Monad (Monad (..))
15 import Control.Monad.Classes qualified as MC
16 import Control.Monad.Trans.Class qualified as MT
17 import Control.Monad.Trans.Except qualified as MT
18 import Control.Monad.Trans.Reader qualified as MT
19 import Control.Monad.Trans.State qualified as MT
20 import Data.Bifunctor (first)
21 import Data.Bool
22 import Data.ByteString.Lazy qualified as BSL
23 import Data.Either (Either (..))
24 import Data.Eq (Eq (..))
25 import Data.Foldable (null)
26 import Data.Function (($), (.))
27 import Data.Functor (Functor, (<$>))
28 import Data.List qualified as List
29 import Data.Maybe (Maybe (..))
30 import Data.Ord (Ord)
31 import Data.Semigroup (Semigroup (..))
32 import Data.Set (Set)
33 import Data.Set qualified as Set
34 import Data.Text qualified as Text
35 import Data.Text.Encoding.Error qualified as Text
36 import Symantic.Syntaxes (Iso (..))
37 import System.IO (IO)
38 import Text.Show (Show (..))
39 import Prelude (min)
40
41 --
42 import Literate.Web.Syntaxes
43
44 -- import Literate.Web.Types.MIME
45 import Literate.Web.Types.URL
46
47 -- * The 'Server' interpreter
48
49 -- | A very very basic parser.
50 newtype Server err m a = Server
51 { unServer ::
52 MT.ReaderT
53 Request
54 ( MT.StateT
55 ServerState
56 (MT.ExceptT (ServerError err) m)
57 )
58 a
59 }
60 deriving (Functor, Applicative, Monad)
61
62 -- ** Type 'Request'
63 data Request = Request
64 { requestPathSegments :: [PathSegment]
65 , requestBody :: BSL.ByteString
66 }
67
68 {-
69 data Servers err a = Servers
70 { serversPath :: [PathSegment] -> a
71 , serversMethod :: [PathSegment] -> Bool
72 --, serversBasicAuth ::
73 , serversAccept :: Bool
74 , serversContentType :: Bool
75 , serversQuery :: Bool
76 , serversHeader :: Bool
77 , serversBody :: BSL.ByteString -> a
78 }
79 -}
80
81 data ServerState = ServerState
82 { serverStatePathSegments :: [PathSegment]
83 }
84
85 decode :: (Monad m) => Server err m a -> Request -> m (Either (ServerError err) a)
86 decode (Server dec) req =
87 MT.runExceptT (MT.runStateT (MT.runReaderT dec req) st) >>= \case
88 Left err -> return $ Left err
89 Right (a, ServerState{..})
90 | null serverStatePathSegments -> return $ Right a
91 | otherwise -> return $ Left $ ServerErrorPathLeftover serverStatePathSegments
92 where
93 st =
94 ServerState
95 { serverStatePathSegments = requestPathSegments req
96 }
97
98 data ServerError err
99 = -- 1st checks, 404 error
100 ServerErrorPathMismatch
101 { expectedPathSegments :: Set PathSegment
102 , gotPathSegment :: PathSegment
103 }
104 | ServerErrorPathMissing
105 | ServerErrorPathLeftover [PathSegment]
106 | -- 2nd check, 405 error
107 ServerErrorMethod
108 | -- 3rd check, 401 or 403 error
109 ServerErrorBasicAuth
110 | -- 4th check, 406 error
111 ServerErrorAccept
112 | -- 5th check, 415 error
113 ServerErrorContentType
114 | -- 6th check, 400 error
115 ServerErrorQuery
116 | -- 7th check, 400 error
117 ServerErrorHeader
118 | -- 8th check, 400 error
119 ServerErrorUnicode Text.UnicodeException
120 | -- 9th check, custom
121 ServerErrorParser err
122 deriving (Eq, Ord, Show)
123 deriving instance Ord Text.UnicodeException
124
125 instance (Monad m) => IsoFunctor (Server err m) where
126 (<%>) Iso{..} = (a2b <$>)
127 instance (Monad m) => ProductFunctor (Server err m) where
128 (<.>) = liftA2 (,)
129 (<.) = (<*)
130 (.>) = (*>)
131 instance (Monad m, Ord err) => SumFunctor (Server err m) where
132 Server x <+> Server y = Server $
133 MT.ReaderT $ \env -> MT.StateT $ \st -> do
134 MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
135 Right (a, st') -> return (Left a, st')
136 Left xErr ->
137 -- TODO: better error merging
138 MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT y env) st)) >>= \case
139 Right (b, st') -> return (Right b, st')
140 Left yErr -> MT.throwE (min xErr yErr)
141
142 -- instance Endable (Server err m) where
143 -- end = Server do
144 -- MT.lift (MT.gets serverStatePathSegments) >>= \case
145 -- [] -> return ()
146 -- lo -> MT.lift $ MT.lift $ MT.throwE $ ServerErrorPathLeftover lo
147 instance (Monad m) => Repeatable (Server err m) where
148 many0 (Server x) = Server (MT.ReaderT (MT.StateT . go))
149 where
150 go env st = do
151 MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
152 Left _err -> return ([], st) -- always backtrack
153 Right (a, st') -> first (a :) <$> go env st'
154 many1 x = (:) <$> x <*> many0 x
155 instance (Monad m) => Optionable (Server err m) where
156 optional (Server x) = Server $
157 MT.ReaderT $ \env -> MT.StateT $ \st -> do
158 MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
159 Left{} -> return (Nothing, st)
160 Right (a, st') -> return (Just a, st')
161 instance (Monad m) => PathSegmentable (Server err m) where
162 pathSegment expectedPathSegment = Server $ do
163 ps <- MT.lift (MT.gets serverStatePathSegments)
164 case ps of
165 [] -> MT.lift $ MT.lift $ MT.throwE ServerErrorPathMissing
166 gotPathSegment : nextPathSegments
167 | expectedPathSegment /= gotPathSegment ->
168 MT.lift $ MT.lift $ MT.throwE ServerErrorPathMismatch{expectedPathSegments = Set.singleton expectedPathSegment, ..}
169 | otherwise ->
170 MT.local (\req -> req{requestPathSegments = requestPathSegments req <> [gotPathSegment]}) $
171 MT.lift $
172 MT.modify' $
173 \st -> st{serverStatePathSegments = nextPathSegments}
174
175 -- choosePathSegment expectedPathSegments = Server $ do
176 -- ps <- MT.lift (MT.gets serverStatePathSegments)
177 -- case ps of
178 -- [] -> MT.lift $ MT.lift $ MT.throwE ServerErrorPathMissing
179 -- gotPathSegment : nextPathSegments
180 -- | gotPathSegment `Set.notMember` expectedPathSegments ->
181 -- MT.lift $ MT.lift $ MT.throwE ServerErrorPathMismatch{expectedPathSegments, ..}
182 -- | otherwise -> do
183 -- MT.local (\req -> req{requestPathSegments = requestPathSegments req <> [gotPathSegment]}) $
184 -- MT.lift $ MT.modify' $ \st -> st{serverStatePathSegments = nextPathSegments}
185 -- return gotPathSegment
186 {-
187 instance ContentTypeable PlainText BSL.ByteString (Server err m) where
188 contentType = Server do
189 Request{..} <- MT.ask
190 return requestBody
191 instance ContentTypeable PlainText Text.Text (Server err m) where
192 contentType = Server do
193 Request{..} <- MT.ask
194 case Text.decodeUtf8' (BSL.toStrict requestBody) of
195 Right a -> return a
196 Left err -> MT.lift $ MT.lift $ MT.throwE $ ServerErrorUnicode err
197 -}
198
199 -- choosePathSegments = undefined
200 -- choosePathSegments expectedPathSegments = Server $ do
201 -- ps <- MT.lift MT.get
202 -- case ps of
203 -- [] -> MT.lift $ MT.lift $ MT.throwE ServerErrorPathMissing
204 -- gotPathSegment : nextPathSegments
205 -- | gotPathSegment `Set.member` expectedPathSegments ->
206 -- MT.lift $ MT.lift $ MT.throwE $ ServerErrorPathMismatch{expectedPathSegments, ..}
207 -- | otherwise -> do
208 -- MT.local (<> [gotPathSegment]) $
209 -- MT.lift $ MT.put nextPathSegments
210 -- return gotPathSegment
211 instance (Monad m) => Capturable PathSegment (Server err m) where
212 capturePathSegment _name = Server $ do
213 ps <- MT.lift (MT.gets serverStatePathSegments)
214 case ps of
215 [] -> MT.lift $ MT.lift $ MT.throwE ServerErrorPathMissing
216 gotPathSegment : nextPathSegments ->
217 MT.local (\req -> req{requestPathSegments = requestPathSegments req <> [gotPathSegment]}) do
218 MT.lift $ MT.modify' $ \st -> st{serverStatePathSegments = nextPathSegments}
219 return gotPathSegment
220
221 -- choosePathSegment expectedPathSegments = Server $ do
222 -- ps <- MT.lift MT.get
223 -- case ps of
224 -- [] -> MT.lift $ MT.lift $ MT.throwE ServerErrorPathMissing
225 -- gotPathSegment : nextPathSegments
226 -- | gotPathSegment `Set.member` expectedPathSegments ->
227 -- MT.lift $ MT.lift $ MT.throwE $ ServerErrorPathMismatch{..}
228 -- | otherwise -> do
229 -- MT.local (<> [gotPathSegment]) $
230 -- MT.lift $ MT.put nextPathSegments
231 -- return gotPathSegment
232 {-
233 instance Selectable (Server err m) where
234 select ra a2bs = do
235 a <- ra
236 case Map.lookup a a2bs of
237 Nothing ->
238 Server $ MT.lift $ MT.lift $ MT.throwE
239 ServerErrorPathMissing -- FIXME
240 where
241 go a [] = Server $
242 MT.lift $ MT.lift $ MT.throwE
243 ServerErrorPathMissing -- FIXME
244 go a ((ca, x):xs) = Server $
245 MT.ReaderT $ \env -> MT.StateT $ \st -> do
246 MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT (unServer x) env) st)) >>= \case
247 Right r -> return r
248 Left _err ->
249 MT.runStateT (MT.runReaderT (unServer (choose ra xs)) env) st
250 -}
251 instance (MC.MonadExec IO m) => Fileable (Server err m) where
252 type FileableConstraint (Server err m) = Parsable err
253 static = Server do
254 return ()
255 dynamic = Server do
256 Request{..} <- MT.ask
257 content <-
258 MT.lift $
259 MT.lift $
260 MT.lift $
261 MC.exec @IO $
262 BSL.readFile $
263 List.intercalate "/" $
264 Text.unpack . encodePathSegment <$> requestPathSegments
265 case parse content of
266 Right a -> return a
267 Left err -> MT.lift $ MT.lift $ MT.throwE $ ServerErrorParser err
268
269 -- * Class 'Parsable'
270 class Parsable err a where
271 parse :: BSL.ByteString -> Either err a