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