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(..))

-- | `ResponderM` is an Either-like monad that can "short-circuit" and return a
-- response, or pass control to the next middleware. This provides convenient
-- branching with do notation for redirects, error responses, etc.
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

-- | Parse values from request parameters.
class ParsableParam a where
  parseParam :: Text -> Either HttpError a

  -- | Default implementation parses comma-delimited lists.
  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)

-- ParsableParam class and instance code is from Andrew Farmer and Scotty
-- framework, with slight modifications.

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 -- String

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

-- | Useful for creating 'ParsableParam' instances for things that already implement 'Read'.
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