src/Webc/Decoder.hs

   1 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
   2 {-# LANGUAGE StandaloneDeriving #-}
   3 {-# LANGUAGE UndecidableInstances #-}
   4 {-# OPTIONS_GHC -Wno-orphans #-}
   5
   6 module Webc.Decoder 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 Network.URI.Slug
  35 import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), Optionable (..), ProductFunctor (..), SumFunctor ((<+>)))
  36 import System.IO (IO)
  37 import Text.Show (Show (..))
  38
  39 --import Network.Wai qualified as Wai
  40
  41 -- import Prelude (undefined)
  42
  43 import Webc.Classes
  44 import Webc.MIME
  45
  46 -- * The 'Decoder' interpreter
  47
  48 -- | A very very basic parser.
  49 newtype Decoder err a = Decoder
  50   { unDecoder ::
  51       MT.ReaderT
  52         Request
  53         ( MT.StateT
  54             DecoderState
  55             (MT.ExceptT (DecoderError err) IO)
  56         )
  57         a
  58   }
  59   deriving (Functor, Applicative, Monad)
  60
  61 -- ** Type 'Request'
  62 data Request = Request
  63   { requestSlugs :: [Slug]
  64   , requestBody :: BSL.ByteString
  65   }
  66
  67 {-
  68 data Decoders err a = Decoders
  69   { decodersPath :: [Slug] -> a
  70   , decodersMethod :: [Slug] -> Bool
  71   --, decodersBasicAuth ::
  72   , decodersAccept :: Bool
  73   , decodersContentType :: Bool
  74   , decodersQuery :: Bool
  75   , decodersHeader :: Bool
  76   , decodersBody :: BSL.ByteString -> a
  77   }
  78 -}
  79
  80 data DecoderState = DecoderState
  81   { decoderStateSlugs :: [Slug]
  82   }
  83
  84 decode :: Decoder err a -> Request -> IO (Either (DecoderError err) a)
  85 decode (Decoder dec) req =
  86   MT.runExceptT (MT.runStateT (MT.runReaderT dec req) st) >>= \case
  87     Left err -> return $ Left err
  88     Right (a, DecoderState{..})
  89       | null decoderStateSlugs -> return $ Right a
  90       | otherwise -> return $ Left $ DecoderErrorPathLeftover decoderStateSlugs
  91   where
  92     st =
  93       DecoderState
  94         { decoderStateSlugs = requestSlugs req
  95         }
  96
  97 data DecoderError err
  98   = -- 1st checks, 404 error
  99     DecoderErrorPathMismatch
 100       { expectedSlugs :: Set Slug
 101       , gotSlug :: Slug
 102       }
 103   | DecoderErrorPathMissing
 104   | DecoderErrorPathLeftover [Slug]
 105   | -- 2nd check, 405 error
 106     DecoderErrorMethod
 107   | -- 3rd check, 401 or 403 error
 108     DecoderErrorBasicAuth
 109   | -- 4th check, 406 error
 110     DecoderErrorAccept
 111   | -- 5th check, 415 error
 112     DecoderErrorContentType
 113   | -- 6th check, 400 error
 114     DecoderErrorQuery
 115   | -- 7th check, 400 error
 116     DecoderErrorHeader
 117   | -- 8th check, 400 error
 118     DecoderErrorUnicode Text.UnicodeException
 119   | -- 9th check, custom
 120     DecoderErrorParser err
 121   deriving (Eq, Show)
 122 deriving instance Ord Text.UnicodeException
 123
 124 instance IsoFunctor (Decoder err) where
 125   (<%>) Iso{..} = (a2b <$>)
 126 instance ProductFunctor (Decoder err) where
 127   (<.>) = liftA2 (,)
 128   (<.) = (<*)
 129   (.>) = (*>)
 130 instance SumFunctor (Decoder err) where
 131   Decoder x <+> Decoder y = Decoder $
 132     MT.ReaderT $ \env -> MT.StateT $ \st -> do
 133       MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
 134         Right (a, st') -> return (Left a, st')
 135         Left _err ->
 136           -- TODO: better error merging
 137           MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT y env) st)) >>= \case
 138             Right (b, st') -> return (Right b, st')
 139             Left err -> MT.throwE err
 140 instance Endable (Decoder err) where
 141   end = Decoder do
 142     MT.lift (MT.gets decoderStateSlugs) >>= \case
 143       [] -> return ()
 144       lo -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorPathLeftover lo
 145 instance Repeatable (Decoder err) where
 146   many0 (Decoder x) = Decoder (MT.ReaderT (MT.StateT . go))
 147     where
 148       go env st = do
 149         MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
 150           Left _err -> return ([], st) -- always backtrack
 151           Right (a, st') -> first (a :) <$> go env st'
 152   many1 x = (:) <$> x <*> many0 x
 153 instance Optionable (Decoder err) where
 154   optional (Decoder x) = Decoder $
 155     MT.ReaderT $ \env -> MT.StateT $ \st -> do
 156       MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT x env) st)) >>= \case
 157         Left{} -> return (Nothing, st)
 158         Right (a, st') -> return (Just a, st')
 159 instance Slugable (Decoder err) where
 160   literalSlug expectedSlug = Decoder $ do
 161     slugs <- MT.lift (MT.gets decoderStateSlugs)
 162     case slugs of
 163       [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
 164       gotSlug : nextSlugs
 165         | expectedSlug /= gotSlug ->
 166           MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMismatch{expectedSlugs = Set.singleton expectedSlug, ..}
 167         | otherwise ->
 168           MT.local (\req -> req{requestSlugs = requestSlugs req <> [gotSlug]}) $
 169             MT.lift $ MT.modify' $ \st -> st{decoderStateSlugs = nextSlugs}
 170   chooseSlug expectedSlugs = Decoder $ do
 171     slugs <- MT.lift (MT.gets decoderStateSlugs)
 172     case slugs of
 173       [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
 174       gotSlug : nextSlugs
 175         | gotSlug `Set.notMember` expectedSlugs ->
 176           MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMismatch{expectedSlugs, ..}
 177         | otherwise -> do
 178           MT.local (\req -> req{requestSlugs = requestSlugs req <> [gotSlug]}) $
 179             MT.lift $ MT.modify' $ \st -> st{decoderStateSlugs = nextSlugs}
 180           return gotSlug
 181 instance ContentTypeable PlainText BSL.ByteString (Decoder err) where
 182   contentType = Decoder do
 183     Request{..} <- MT.ask
 184     return requestBody
 185 instance ContentTypeable PlainText Text.Text (Decoder err) where
 186   contentType = Decoder do
 187     Request{..} <- MT.ask
 188     case Text.decodeUtf8' (BSL.toStrict requestBody) of
 189       Right a -> return a
 190       Left err -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorUnicode err
 191
 192 -- chooseSlugs = undefined
 193 -- chooseSlugs expectedSlugs = Decoder $ do
 194 --   slugs <- MT.lift MT.get
 195 --   case slugs of
 196 --     [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
 197 --     gotSlug : nextSlugs
 198 --       | gotSlug `Set.member` expectedSlugs ->
 199 --         MT.lift $ MT.lift $ MT.throwE $ DecoderErrorPathMismatch{expectedSlugs, ..}
 200 --       | otherwise -> do
 201 --         MT.local (<> [gotSlug]) $
 202 --           MT.lift $ MT.put nextSlugs
 203 --         return gotSlug
 204 instance Capturable (Decoder err) where
 205   captureSlug _name = Decoder $ do
 206     slugs <- MT.lift (MT.gets decoderStateSlugs)
 207     case slugs of
 208       [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
 209       gotSlug : nextSlugs ->
 210         MT.local (\req -> req{requestSlugs = requestSlugs req <> [gotSlug]}) do
 211           MT.lift $ MT.modify' $ \st -> st{decoderStateSlugs = nextSlugs}
 212           return gotSlug
 213
 214 --chooseSlug expectedSlugs = Decoder $ do
 215 --  slugs <- MT.lift MT.get
 216 --  case slugs of
 217 --    [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
 218 --    gotSlug : nextSlugs
 219 --      | gotSlug `Set.member` expectedSlugs ->
 220 --        MT.lift $ MT.lift $ MT.throwE $ DecoderErrorPathMismatch{..}
 221 --      | otherwise -> do
 222 --        MT.local (<> [gotSlug]) $
 223 --          MT.lift $ MT.put nextSlugs
 224 --        return gotSlug
 225 {-
 226 instance Selectable (Decoder err) where
 227   select ra a2bs = do
 228     a <- ra
 229     case Map.lookup a a2bs of
 230       Nothing ->
 231         Decoder $ MT.lift $ MT.lift $ MT.throwE
 232           DecoderErrorPathMissing -- FIXME
 233     where
 234     go a [] = Decoder $
 235       MT.lift $ MT.lift $ MT.throwE
 236         DecoderErrorPathMissing -- FIXME
 237     go a ((ca, x):xs) = Decoder $
 238       MT.ReaderT $ \env -> MT.StateT $ \st -> do
 239         MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT (unDecoder x) env) st)) >>= \case
 240           Right r -> return r
 241           Left _err ->
 242             MT.runStateT (MT.runReaderT (unDecoder (choose ra xs)) env) st
 243 -}
 244 instance Fileable (Decoder err) where
 245   type FileableConstraint (Decoder err) = Parsable err
 246   static = Decoder do
 247     return ()
 248   dynamic = Decoder do
 249     Request{..} <- MT.ask
 250     content <-
 251       MT.lift $
 252         MT.lift $
 253           MT.lift $
 254             BSL.readFile $
 255               List.intercalate "/" $
 256                 Text.unpack . encodeSlug <$> requestSlugs
 257     case parse content of
 258       Right a -> return a
 259       Left err -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorParser err
 260
 261 -- * Class 'Parsable'
 262 class Parsable err a where
 263   parse :: BSL.ByteString -> Either err a