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

-- | `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 :: (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 (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 :: 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 (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))
  <*> :: 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) >>= :: 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 (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 :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> Either RouteAction (a, Request)
-> IO (Either RouteAction (a, Request))
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 :: e -> ResponderM a
throwM = 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 :: 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 (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
/= :: HttpError -> HttpError -> Bool
$c/= :: HttpError -> HttpError -> Bool
== :: HttpError -> HttpError -> Bool
$c== :: 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
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) ([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
&& 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)
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 :: 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"