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

-- | 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 = 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)

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

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

-- | 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
"") <- 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"