module Web.Twain.Types where
import Control.Exception (SomeException, throwIO, try)
import Control.Monad (ap)
import Control.Monad.Catch hiding (throw, try)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson as JSON
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Either.Combinators (mapRight)
import Data.Int
import Data.List as L
import Data.String (IsString, fromString)
import Data.Text as T
import Data.Text.Encoding
import qualified Data.Text.Lazy as TL
import Data.Typeable (Typeable)
import Data.Word
import Network.HTTP.Types (Status, status400)
import Network.Wai (Middleware, Request, Response, pathInfo)
import Network.Wai.Parse (File, ParseRequestBodyOptions)
import Numeric.Natural
import Network.HTTP2.Client (ErrorCode(..))
data ResponderM a
= ResponderM (Request -> IO (Either RouteAction (a, Request)))
data RouteAction
= Respond Response
| Next
data ParsedRequest
= ParsedRequest
{ ParsedRequest -> Maybe ParsedBody
preqBody :: Maybe ParsedBody,
ParsedRequest -> [Param]
preqCookieParams :: [Param],
ParsedRequest -> [Param]
preqPathParams :: [Param],
ParsedRequest -> [Param]
preqQueryParams :: [Param]
}
data ResponderOptions
= ResponderOptions
{ ResponderOptions -> Word64
optsMaxBodySize :: Word64,
ResponderOptions -> ParseRequestBodyOptions
optsParseBody :: ParseRequestBodyOptions
}
data ParsedBody
= FormBody ([Param], [File BL.ByteString])
| JSONBody JSON.Value
instance Functor ResponderM where
fmap :: forall a b. (a -> b) -> ResponderM a -> ResponderM b
fmap a -> b
f (ResponderM Request -> IO (Either RouteAction (a, Request))
g) = (Request -> IO (Either RouteAction (b, Request))) -> ResponderM b
forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM ((Request -> IO (Either RouteAction (b, Request))) -> ResponderM b)
-> (Request -> IO (Either RouteAction (b, Request)))
-> ResponderM b
forall a b. (a -> b) -> a -> b
$ \Request
r -> ((a, Request) -> (b, Request))
-> Either RouteAction (a, Request)
-> Either RouteAction (b, Request)
forall b c a. (b -> c) -> Either a b -> Either a c
mapRight (\(a
a, Request
b) -> (a -> b
f a
a, Request
b)) (Either RouteAction (a, Request)
-> Either RouteAction (b, Request))
-> IO (Either RouteAction (a, Request))
-> IO (Either RouteAction (b, Request))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Request -> IO (Either RouteAction (a, Request))
g Request
r
instance Applicative ResponderM where
pure :: forall a. a -> ResponderM a
pure a
a = (Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM ((Request -> IO (Either RouteAction (a, Request))) -> ResponderM a)
-> (Request -> IO (Either RouteAction (a, Request)))
-> ResponderM a
forall a b. (a -> b) -> a -> b
$ \Request
r -> Either RouteAction (a, Request)
-> IO (Either RouteAction (a, Request))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, Request) -> Either RouteAction (a, Request)
forall a b. b -> Either a b
Right (a
a, Request
r))
<*> :: forall a b. ResponderM (a -> b) -> ResponderM a -> ResponderM b
(<*>) = ResponderM (a -> b) -> ResponderM a -> ResponderM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad ResponderM where
(ResponderM Request -> IO (Either RouteAction (a, Request))
act) >>= :: forall a b. ResponderM a -> (a -> ResponderM b) -> ResponderM b
>>= a -> ResponderM b
fn = (Request -> IO (Either RouteAction (b, Request))) -> ResponderM b
forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM ((Request -> IO (Either RouteAction (b, Request))) -> ResponderM b)
-> (Request -> IO (Either RouteAction (b, Request)))
-> ResponderM b
forall a b. (a -> b) -> a -> b
$ \Request
r -> do
Either RouteAction (a, Request)
eres <- Request -> IO (Either RouteAction (a, Request))
act Request
r
case Either RouteAction (a, Request)
eres of
Left RouteAction
ract -> Either RouteAction (b, Request)
-> IO (Either RouteAction (b, Request))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteAction -> Either RouteAction (b, Request)
forall a b. a -> Either a b
Left RouteAction
ract)
Right (a
a, Request
r') -> do
let (ResponderM Request -> IO (Either RouteAction (b, Request))
fres) = a -> ResponderM b
fn a
a
Request -> IO (Either RouteAction (b, Request))
fres Request
r'
instance MonadIO ResponderM where
liftIO :: forall a. IO a -> ResponderM a
liftIO IO a
act = (Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM ((Request -> IO (Either RouteAction (a, Request))) -> ResponderM a)
-> (Request -> IO (Either RouteAction (a, Request)))
-> ResponderM a
forall a b. (a -> b) -> a -> b
$ \Request
r -> IO a
act IO a
-> (a -> IO (Either RouteAction (a, Request)))
-> IO (Either RouteAction (a, Request))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> Either RouteAction (a, Request)
-> IO (Either RouteAction (a, Request))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Request) -> Either RouteAction (a, Request)
forall a b. b -> Either a b
Right (a
a, Request
r))
instance MonadThrow ResponderM where
throwM :: forall e a. (HasCallStack, Exception e) => e -> ResponderM a
throwM = IO a -> ResponderM a
forall a. IO a -> ResponderM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ResponderM a) -> (e -> IO a) -> e -> ResponderM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IO a
forall e a. Exception e => e -> IO a
throwIO
instance MonadCatch ResponderM where
catch :: forall e a.
(HasCallStack, Exception e) =>
ResponderM a -> (e -> ResponderM a) -> ResponderM a
catch (ResponderM Request -> IO (Either RouteAction (a, Request))
act) e -> ResponderM a
f = (Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM ((Request -> IO (Either RouteAction (a, Request))) -> ResponderM a)
-> (Request -> IO (Either RouteAction (a, Request)))
-> ResponderM a
forall a b. (a -> b) -> a -> b
$ \Request
r -> do
Either e (Either RouteAction (a, Request))
ea <- IO (Either RouteAction (a, Request))
-> IO (Either e (Either RouteAction (a, Request)))
forall e a. Exception e => IO a -> IO (Either e a)
try (Request -> IO (Either RouteAction (a, Request))
act Request
r)
case Either e (Either RouteAction (a, Request))
ea of
Left e
e ->
let (ResponderM Request -> IO (Either RouteAction (a, Request))
h) = e -> ResponderM a
f e
e
in Request -> IO (Either RouteAction (a, Request))
h Request
r
Right Either RouteAction (a, Request)
a -> Either RouteAction (a, Request)
-> IO (Either RouteAction (a, Request))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either RouteAction (a, Request)
a
data HttpError = HttpError Status String
deriving (HttpError -> HttpError -> Bool
(HttpError -> HttpError -> Bool)
-> (HttpError -> HttpError -> Bool) -> Eq HttpError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HttpError -> HttpError -> Bool
== :: HttpError -> HttpError -> Bool
$c/= :: HttpError -> HttpError -> Bool
/= :: HttpError -> HttpError -> Bool
Eq, Int -> HttpError -> ShowS
[HttpError] -> ShowS
HttpError -> String
(Int -> HttpError -> ShowS)
-> (HttpError -> String)
-> ([HttpError] -> ShowS)
-> Show HttpError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HttpError -> ShowS
showsPrec :: Int -> HttpError -> ShowS
$cshow :: HttpError -> String
show :: HttpError -> String
$cshowList :: [HttpError] -> ShowS
showList :: [HttpError] -> ShowS
Show)
instance Exception HttpError
type Param = (Text, Text)
data PathPattern = MatchPath (Request -> Maybe [Param])
instance IsString PathPattern where
fromString :: String -> PathPattern
fromString String
s = (Request -> Maybe [Param]) -> PathPattern
MatchPath (Text -> Request -> Maybe [Param]
matchPath (String -> Text
T.pack String
s))
matchPath :: Text -> Request -> Maybe [Param]
matchPath :: Text -> Request -> Maybe [Param]
matchPath Text
path Request
req =
[Text] -> [Text] -> Maybe [Param] -> Maybe [Param]
go (Text -> [Text]
splitPath Text
path) (Request -> [Text]
pathInfo Request
req) ([Param] -> Maybe [Param]
forall a. a -> Maybe a
Just [])
where
splitPath :: Text -> [Text]
splitPath = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
go :: [Text] -> [Text] -> Maybe [Param] -> Maybe [Param]
go (Text
p : [Text]
ps) (Text
r : [Text]
rs) m :: Maybe [Param]
m@(Just [Param]
pms) =
if Bool -> Bool
not (Text -> Bool
T.null Text
p) Bool -> Bool -> Bool
&& HasCallStack => Text -> Char
Text -> Char
T.head Text
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'
then [Text] -> [Text] -> Maybe [Param] -> Maybe [Param]
go [Text]
ps [Text]
rs ([Param] -> Maybe [Param]
forall a. a -> Maybe a
Just ((Int -> Text -> Text
T.drop Int
1 Text
p, Text
r) Param -> [Param] -> [Param]
forall a. a -> [a] -> [a]
: [Param]
pms))
else if Text
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
r then [Text] -> [Text] -> Maybe [Param] -> Maybe [Param]
go [Text]
ps [Text]
rs Maybe [Param]
m else Maybe [Param]
forall a. Maybe a
Nothing
go [] [] Maybe [Param]
pms = Maybe [Param]
pms
go [Text]
_ [Text]
_ Maybe [Param]
_ = Maybe [Param]
forall a. Maybe a
Nothing
class ParsableParam a where
parseParam :: Text -> Either HttpError a
parseParamList :: Text -> Either HttpError [a]
parseParamList Text
t = (Text -> Either HttpError a) -> [Text] -> Either HttpError [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Text -> Either HttpError a
forall a. ParsableParam a => Text -> Either HttpError a
parseParam ((Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') Text
t)
instance ParsableParam TL.Text where parseParam :: Text -> Either HttpError Text
parseParam = Text -> Either HttpError Text
forall a b. b -> Either a b
Right (Text -> Either HttpError Text)
-> (Text -> Text) -> Text -> Either HttpError Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
instance ParsableParam T.Text where parseParam :: Text -> Either HttpError Text
parseParam = Text -> Either HttpError Text
forall a b. b -> Either a b
Right
instance ParsableParam B.ByteString where parseParam :: Text -> Either HttpError ByteString
parseParam = ByteString -> Either HttpError ByteString
forall a b. b -> Either a b
Right (ByteString -> Either HttpError ByteString)
-> (Text -> ByteString) -> Text -> Either HttpError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
instance ParsableParam BL.ByteString where parseParam :: Text -> Either HttpError ByteString
parseParam = ByteString -> Either HttpError ByteString
forall a b. b -> Either a b
Right (ByteString -> Either HttpError ByteString)
-> (Text -> ByteString) -> Text -> Either HttpError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
instance ParsableParam Char where
parseParam :: Text -> Either HttpError Char
parseParam Text
t = case Text -> String
T.unpack Text
t of
[Char
c] -> Char -> Either HttpError Char
forall a b. b -> Either a b
Right Char
c
String
_ -> HttpError -> Either HttpError Char
forall a b. a -> Either a b
Left (HttpError -> Either HttpError Char)
-> HttpError -> Either HttpError Char
forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 String
"parseParam Char: no parse"
parseParamList :: Text -> Either HttpError String
parseParamList = String -> Either HttpError String
forall a b. b -> Either a b
Right (String -> Either HttpError String)
-> (Text -> String) -> Text -> Either HttpError String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
instance ParsableParam () where
parseParam :: Text -> Either HttpError ()
parseParam Text
t =
if Text -> Bool
T.null Text
t
then () -> Either HttpError ()
forall a b. b -> Either a b
Right ()
else HttpError -> Either HttpError ()
forall a b. a -> Either a b
Left (HttpError -> Either HttpError ())
-> HttpError -> Either HttpError ()
forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 String
"parseParam Unit: no parse"
instance (ParsableParam a) => ParsableParam [a] where parseParam :: Text -> Either HttpError [a]
parseParam = Text -> Either HttpError [a]
forall a. ParsableParam a => Text -> Either HttpError [a]
parseParamList
instance ParsableParam Bool where
parseParam :: Text -> Either HttpError Bool
parseParam Text
t =
if Text
t' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
T.toCaseFold Text
"true"
then Bool -> Either HttpError Bool
forall a b. b -> Either a b
Right Bool
True
else
if Text
t' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
T.toCaseFold Text
"false"
then Bool -> Either HttpError Bool
forall a b. b -> Either a b
Right Bool
False
else HttpError -> Either HttpError Bool
forall a b. a -> Either a b
Left (HttpError -> Either HttpError Bool)
-> HttpError -> Either HttpError Bool
forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 String
"parseParam Bool: no parse"
where
t' :: Text
t' = Text -> Text
T.toCaseFold Text
t
instance ParsableParam Double where parseParam :: Text -> Either HttpError Double
parseParam = Text -> Either HttpError Double
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Float where parseParam :: Text -> Either HttpError Float
parseParam = Text -> Either HttpError Float
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Int where parseParam :: Text -> Either HttpError Int
parseParam = Text -> Either HttpError Int
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Int8 where parseParam :: Text -> Either HttpError Int8
parseParam = Text -> Either HttpError Int8
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Int16 where parseParam :: Text -> Either HttpError Int16
parseParam = Text -> Either HttpError Int16
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Int32 where parseParam :: Text -> Either HttpError Int32
parseParam = Text -> Either HttpError Int32
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Int64 where parseParam :: Text -> Either HttpError Int64
parseParam = Text -> Either HttpError Int64
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Integer where parseParam :: Text -> Either HttpError Integer
parseParam = Text -> Either HttpError Integer
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Word where parseParam :: Text -> Either HttpError Word
parseParam = Text -> Either HttpError Word
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Word8 where parseParam :: Text -> Either HttpError Word8
parseParam = Text -> Either HttpError Word8
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Word16 where parseParam :: Text -> Either HttpError Word16
parseParam = Text -> Either HttpError Word16
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Word32 where parseParam :: Text -> Either HttpError Word32
parseParam = Text -> Either HttpError Word32
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Word64 where parseParam :: Text -> Either HttpError Word64
parseParam = Text -> Either HttpError Word64
forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Natural where parseParam :: Text -> Either HttpError Natural
parseParam = Text -> Either HttpError Natural
forall a. Read a => Text -> Either HttpError a
readEither
readEither :: Read a => Text -> Either HttpError a
readEither :: forall a. Read a => Text -> Either HttpError a
readEither Text
t = case [a
x | (a
x, String
"") <- ReadS a
forall a. Read a => ReadS a
reads (Text -> String
T.unpack Text
t)] of
[a
x] -> a -> Either HttpError a
forall a b. b -> Either a b
Right a
x
[] -> HttpError -> Either HttpError a
forall a b. a -> Either a b
Left (HttpError -> Either HttpError a)
-> HttpError -> Either HttpError a
forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 String
"readEither: no parse"
[a]
_ -> HttpError -> Either HttpError a
forall a b. a -> Either a b
Left (HttpError -> Either HttpError a)
-> HttpError -> Either HttpError a
forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 String
"readEither: ambiguous parse"
data HTTP2Exception = HTTP2Exception ErrorCode
deriving (Int -> HTTP2Exception -> ShowS
[HTTP2Exception] -> ShowS
HTTP2Exception -> String
(Int -> HTTP2Exception -> ShowS)
-> (HTTP2Exception -> String)
-> ([HTTP2Exception] -> ShowS)
-> Show HTTP2Exception
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HTTP2Exception -> ShowS
showsPrec :: Int -> HTTP2Exception -> ShowS
$cshow :: HTTP2Exception -> String
show :: HTTP2Exception -> String
$cshowList :: [HTTP2Exception] -> ShowS
showList :: [HTTP2Exception] -> ShowS
Show, Typeable)
instance Exception HTTP2Exception