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.Word
import Network.HTTP.Types (Status, status400)
import Network.Wai (Middleware, Request, Response, pathInfo)
import Network.Wai.Parse (File, ParseRequestBodyOptions)
import Numeric.Natural
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) = forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM forall a b. (a -> b) -> a -> b
$ \Request
r -> forall b c a. (b -> c) -> Either a b -> Either a c
mapRight (\(a
a, Request
b) -> (a -> b
f a
a, Request
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 = forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM forall a b. (a -> b) -> a -> b
$ \Request
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right (a
a, Request
r))
<*> :: forall a 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 = forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM forall a b. (a -> b) -> a -> b
$ \Request
r -> IO a
act forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (a
a, Request
r))
instance MonadThrow ResponderM where
throwM :: forall e a. Exception e => e -> ResponderM a
throwM = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO
instance MonadCatch ResponderM where
catch :: forall e a.
Exception e =>
ResponderM a -> (e -> ResponderM a) -> ResponderM a
catch (ResponderM Request -> IO (Either RouteAction (a, Request))
act) e -> ResponderM a
f = forall a.
(Request -> IO (Either RouteAction (a, Request))) -> ResponderM a
ResponderM forall a b. (a -> b) -> a -> b
$ \Request
r -> do
Either e (Either RouteAction (a, Request))
ea <- 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Either RouteAction (a, Request)
a
data HttpError = HttpError Status String
deriving (HttpError -> HttpError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HttpError -> HttpError -> Bool
$c/= :: HttpError -> HttpError -> Bool
== :: HttpError -> HttpError -> Bool
$c== :: HttpError -> HttpError -> Bool
Eq, Int -> HttpError -> ShowS
[HttpError] -> ShowS
HttpError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HttpError] -> ShowS
$cshowList :: [HttpError] -> ShowS
show :: HttpError -> String
$cshow :: HttpError -> String
showsPrec :: Int -> HttpError -> ShowS
$cshowsPrec :: Int -> 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) (forall a. a -> Maybe a
Just [])
where
splitPath :: Text -> [Text]
splitPath = forall a. (a -> Bool) -> [a] -> [a]
L.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (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
&& Text -> Char
T.head Text
p forall a. Eq a => a -> a -> Bool
== Char
':'
then [Text] -> [Text] -> Maybe [Param] -> Maybe [Param]
go [Text]
ps [Text]
rs (forall a. a -> Maybe a
Just ((Int -> Text -> Text
T.drop Int
1 Text
p, Text
r) forall a. a -> [a] -> [a]
: [Param]
pms))
else if Text
p 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 forall a. Maybe a
Nothing
go [] [] Maybe [Param]
pms = Maybe [Param]
pms
go [Text]
_ [Text]
_ Maybe [Param]
_ = forall a. Maybe a
Nothing
class ParsableParam a where
parseParam :: Text -> Either HttpError a
parseParamList :: Text -> Either HttpError [a]
parseParamList Text
t = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. ParsableParam a => Text -> Either HttpError a
parseParam ((Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
== Char
',') Text
t)
instance ParsableParam TL.Text where parseParam :: Text -> Either HttpError Text
parseParam = forall a b. b -> Either a b
Right 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 = forall a b. b -> Either a b
Right
instance ParsableParam B.ByteString where parseParam :: Text -> Either HttpError ByteString
parseParam = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
instance ParsableParam BL.ByteString where parseParam :: Text -> Either HttpError ByteString
parseParam = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict 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] -> forall a b. b -> Either a b
Right Char
c
String
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 String
"parseParam Char: no parse"
parseParamList :: Text -> Either HttpError String
parseParamList = forall a b. b -> Either a b
Right 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 forall a b. b -> Either a b
Right ()
else forall a b. a -> Either a b
Left 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 = forall a. ParsableParam a => Text -> Either HttpError [a]
parseParamList
instance ParsableParam Bool where
parseParam :: Text -> Either HttpError Bool
parseParam Text
t =
if Text
t' forall a. Eq a => a -> a -> Bool
== Text -> Text
T.toCaseFold Text
"true"
then forall a b. b -> Either a b
Right Bool
True
else
if Text
t' forall a. Eq a => a -> a -> Bool
== Text -> Text
T.toCaseFold Text
"false"
then forall a b. b -> Either a b
Right Bool
False
else forall a b. a -> Either a b
Left 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 = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Float where parseParam :: Text -> Either HttpError Float
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Int where parseParam :: Text -> Either HttpError Int
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Int8 where parseParam :: Text -> Either HttpError Int8
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Int16 where parseParam :: Text -> Either HttpError Int16
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Int32 where parseParam :: Text -> Either HttpError Int32
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Int64 where parseParam :: Text -> Either HttpError Int64
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Integer where parseParam :: Text -> Either HttpError Integer
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Word where parseParam :: Text -> Either HttpError Word
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Word8 where parseParam :: Text -> Either HttpError Word8
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Word16 where parseParam :: Text -> Either HttpError Word16
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Word32 where parseParam :: Text -> Either HttpError Word32
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Word64 where parseParam :: Text -> Either HttpError Word64
parseParam = forall a. Read a => Text -> Either HttpError a
readEither
instance ParsableParam Natural where parseParam :: Text -> Either HttpError Natural
parseParam = 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
"") <- forall a. Read a => ReadS a
reads (Text -> String
T.unpack Text
t)] of
[a
x] -> forall a b. b -> Either a b
Right a
x
[] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 String
"readEither: no parse"
[a]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Status -> String -> HttpError
HttpError Status
status400 String
"readEither: ambiguous parse"