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