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