module Web.Twain.Types where

import Control.Exception (SomeException)
import Control.Monad (ap)
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.Wai (Middleware, Request, Response, pathInfo)
import Network.Wai.Handler.Warp (defaultOnExceptionResponse)
import Network.Wai.Parse (File, ParseRequestBodyOptions)
import Numeric.Natural

-- | TwainM provides a monad interface for composing routes and middleware.
newtype TwainM e a = TwainM (TwainState e -> (a, TwainState e))

data TwainState e
  = TwainState
      { TwainState e -> [Middleware]
middlewares :: [Middleware],
        TwainState e -> e
environment :: e,
        TwainState e -> SomeException -> Response
onExceptionResponse :: (SomeException -> Response)
      }

instance Functor (TwainM e) where
  fmap :: (a -> b) -> TwainM e a -> TwainM e b
fmap a -> b
f (TwainM TwainState e -> (a, TwainState e)
g) = (TwainState e -> (b, TwainState e)) -> TwainM e b
forall e a. (TwainState e -> (a, TwainState e)) -> TwainM e a
TwainM ((TwainState e -> (b, TwainState e)) -> TwainM e b)
-> (TwainState e -> (b, TwainState e)) -> TwainM e b
forall a b. (a -> b) -> a -> b
$ \TwainState e
s ->
    let (a
a, TwainState e
sb) = TwainState e -> (a, TwainState e)
g TwainState e
s
     in (a -> b
f a
a, TwainState e
sb)

instance Applicative (TwainM e) where
  pure :: a -> TwainM e a
pure = a -> TwainM e a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: TwainM e (a -> b) -> TwainM e a -> TwainM e b
(<*>) = TwainM e (a -> b) -> TwainM e a -> TwainM e b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (TwainM e) where
  return :: a -> TwainM e a
return a
a = (TwainState e -> (a, TwainState e)) -> TwainM e a
forall e a. (TwainState e -> (a, TwainState e)) -> TwainM e a
TwainM (\TwainState e
s -> (a
a, TwainState e
s))
  (TwainM TwainState e -> (a, TwainState e)
m) >>= :: TwainM e a -> (a -> TwainM e b) -> TwainM e b
>>= a -> TwainM e b
fn = (TwainState e -> (b, TwainState e)) -> TwainM e b
forall e a. (TwainState e -> (a, TwainState e)) -> TwainM e a
TwainM ((TwainState e -> (b, TwainState e)) -> TwainM e b)
-> (TwainState e -> (b, TwainState e)) -> TwainM e b
forall a b. (a -> b) -> a -> b
$ \TwainState e
s ->
    let (a
a, TwainState e
sb) = TwainState e -> (a, TwainState e)
m TwainState e
s
        (TwainM TwainState e -> (b, TwainState e)
mb) = a -> TwainM e b
fn a
a
     in TwainState e -> (b, TwainState e)
mb TwainState e
sb

modify :: (TwainState e -> TwainState e) -> TwainM e ()
modify :: (TwainState e -> TwainState e) -> TwainM e ()
modify TwainState e -> TwainState e
f = (TwainState e -> ((), TwainState e)) -> TwainM e ()
forall e a. (TwainState e -> (a, TwainState e)) -> TwainM e a
TwainM (\TwainState e
s -> ((), TwainState e -> TwainState e
f TwainState e
s))

exec :: TwainM e a -> e -> TwainState e
exec :: TwainM e a -> e -> TwainState e
exec (TwainM TwainState e -> (a, TwainState e)
f) e
e = (a, TwainState e) -> TwainState e
forall a b. (a, b) -> b
snd (TwainState e -> (a, TwainState e)
f ([Middleware] -> e -> (SomeException -> Response) -> TwainState e
forall e.
[Middleware] -> e -> (SomeException -> Response) -> TwainState e
TwainState [] e
e SomeException -> Response
defaultOnExceptionResponse))

-- | `RouteM` is a Reader-like monad that can "short-circuit" and return a WAI
-- response using a given environment. This provides convenient branching with
-- do notation for redirects, error responses, etc.
data RouteM e a
  = RouteM (RouteState e -> IO (Either RouteAction (a, RouteState e)))

data RouteAction
  = Respond Response
  | Next

data RouteState e
  = RouteState
      { RouteState e -> [Param]
reqBodyParams :: [Param],
        RouteState e -> [File ByteString]
reqBodyFiles :: [File BL.ByteString],
        RouteState e -> [Param]
reqPathParams :: [Param],
        RouteState e -> [Param]
reqQueryParams :: [Param],
        RouteState e -> [Param]
reqCookieParams :: [Param],
        RouteState e -> Either String Value
reqBodyJson :: Either String JSON.Value,
        RouteState e -> Bool
reqBodyParsed :: Bool,
        RouteState e -> e
reqEnv :: e,
        RouteState e -> Request
reqWai :: Request
      }

instance Functor (RouteM e) where
  fmap :: (a -> b) -> RouteM e a -> RouteM e b
fmap a -> b
f (RouteM RouteState e -> IO (Either RouteAction (a, RouteState e))
g) = (RouteState e -> IO (Either RouteAction (b, RouteState e)))
-> RouteM e b
forall e a.
(RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
RouteM ((RouteState e -> IO (Either RouteAction (b, RouteState e)))
 -> RouteM e b)
-> (RouteState e -> IO (Either RouteAction (b, RouteState e)))
-> RouteM e b
forall a b. (a -> b) -> a -> b
$ \RouteState e
s -> ((a, RouteState e) -> (b, RouteState e))
-> Either RouteAction (a, RouteState e)
-> Either RouteAction (b, RouteState e)
forall b c a. (b -> c) -> Either a b -> Either a c
mapRight (\(a
a, RouteState e
b) -> (a -> b
f a
a, RouteState e
b)) (Either RouteAction (a, RouteState e)
 -> Either RouteAction (b, RouteState e))
-> IO (Either RouteAction (a, RouteState e))
-> IO (Either RouteAction (b, RouteState e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RouteState e -> IO (Either RouteAction (a, RouteState e))
g RouteState e
s

instance Applicative (RouteM e) where
  pure :: a -> RouteM e a
pure = a -> RouteM e a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: RouteM e (a -> b) -> RouteM e a -> RouteM e b
(<*>) = RouteM e (a -> b) -> RouteM e a -> RouteM e b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (RouteM e) where
  return :: a -> RouteM e a
return a
a = (RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
forall e a.
(RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
RouteM ((RouteState e -> IO (Either RouteAction (a, RouteState e)))
 -> RouteM e a)
-> (RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
forall a b. (a -> b) -> a -> b
$ \RouteState e
s -> Either RouteAction (a, RouteState e)
-> IO (Either RouteAction (a, RouteState e))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, RouteState e) -> Either RouteAction (a, RouteState e)
forall a b. b -> Either a b
Right (a
a, RouteState e
s))
  (RouteM RouteState e -> IO (Either RouteAction (a, RouteState e))
act) >>= :: RouteM e a -> (a -> RouteM e b) -> RouteM e b
>>= a -> RouteM e b
fn = (RouteState e -> IO (Either RouteAction (b, RouteState e)))
-> RouteM e b
forall e a.
(RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
RouteM ((RouteState e -> IO (Either RouteAction (b, RouteState e)))
 -> RouteM e b)
-> (RouteState e -> IO (Either RouteAction (b, RouteState e)))
-> RouteM e b
forall a b. (a -> b) -> a -> b
$ \RouteState e
s -> do
    Either RouteAction (a, RouteState e)
eres <- RouteState e -> IO (Either RouteAction (a, RouteState e))
act RouteState e
s
    case Either RouteAction (a, RouteState e)
eres of
      Left RouteAction
ract -> Either RouteAction (b, RouteState e)
-> IO (Either RouteAction (b, RouteState e))
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteAction -> Either RouteAction (b, RouteState e)
forall a b. a -> Either a b
Left RouteAction
ract)
      Right (a
a, RouteState e
sb) -> do
        let (RouteM RouteState e -> IO (Either RouteAction (b, RouteState e))
fres) = a -> RouteM e b
fn a
a
        RouteState e -> IO (Either RouteAction (b, RouteState e))
fres RouteState e
sb

instance MonadIO (RouteM e) where
  liftIO :: IO a -> RouteM e a
liftIO IO a
act = (RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
forall e a.
(RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
RouteM ((RouteState e -> IO (Either RouteAction (a, RouteState e)))
 -> RouteM e a)
-> (RouteState e -> IO (Either RouteAction (a, RouteState e)))
-> RouteM e a
forall a b. (a -> b) -> a -> b
$ \RouteState e
s -> IO a
act IO a
-> (a -> IO (Either RouteAction (a, RouteState e)))
-> IO (Either RouteAction (a, RouteState e))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> Either RouteAction (a, RouteState e)
-> IO (Either RouteAction (a, RouteState e))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, RouteState e) -> Either RouteAction (a, RouteState e)
forall a b. b -> Either a b
Right (a
a, RouteState e
s))

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 Text a

  -- | Default implementation parses comma-delimited lists.
  parseParamList :: Text -> Either Text [a]
  parseParamList Text
t = (Text -> Either Text a) -> [Text] -> Either Text [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Either Text a
forall a. ParsableParam a => Text -> Either Text 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 Text Text
parseParam = Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text)
-> (Text -> Text) -> Text -> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict

instance ParsableParam T.Text where parseParam :: Text -> Either Text Text
parseParam = Text -> Either Text Text
forall a b. b -> Either a b
Right

instance ParsableParam B.ByteString where parseParam :: Text -> Either Text ByteString
parseParam = ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right (ByteString -> Either Text ByteString)
-> (Text -> ByteString) -> Text -> Either Text ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

instance ParsableParam BL.ByteString where parseParam :: Text -> Either Text ByteString
parseParam = ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right (ByteString -> Either Text ByteString)
-> (Text -> ByteString) -> Text -> Either Text 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 Text Char
parseParam Text
t = case Text -> String
T.unpack Text
t of
    [Char
c] -> Char -> Either Text Char
forall a b. b -> Either a b
Right Char
c
    String
_ -> Text -> Either Text Char
forall a b. a -> Either a b
Left Text
"parseParam Char: no parse"
  parseParamList :: Text -> Either Text String
parseParamList = String -> Either Text String
forall a b. b -> Either a b
Right (String -> Either Text String)
-> (Text -> String) -> Text -> Either Text String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack -- String

instance ParsableParam () where
  parseParam :: Text -> Either Text ()
parseParam Text
t = if Text -> Bool
T.null Text
t then () -> Either Text ()
forall a b. b -> Either a b
Right () else Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"parseParam Unit: no parse"

instance (ParsableParam a) => ParsableParam [a] where parseParam :: Text -> Either Text [a]
parseParam = Text -> Either Text [a]
forall a. ParsableParam a => Text -> Either Text [a]
parseParamList

instance ParsableParam Bool where
  parseParam :: Text -> Either Text 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 Text 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 Text Bool
forall a b. b -> Either a b
Right Bool
False
          else Text -> Either Text Bool
forall a b. a -> Either a b
Left Text
"parseParam Bool: no parse"
    where
      t' :: Text
t' = Text -> Text
T.toCaseFold Text
t

instance ParsableParam Double where parseParam :: Text -> Either Text Double
parseParam = Text -> Either Text Double
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Float where parseParam :: Text -> Either Text Float
parseParam = Text -> Either Text Float
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Int where parseParam :: Text -> Either Text Int
parseParam = Text -> Either Text Int
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Int8 where parseParam :: Text -> Either Text Int8
parseParam = Text -> Either Text Int8
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Int16 where parseParam :: Text -> Either Text Int16
parseParam = Text -> Either Text Int16
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Int32 where parseParam :: Text -> Either Text Int32
parseParam = Text -> Either Text Int32
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Int64 where parseParam :: Text -> Either Text Int64
parseParam = Text -> Either Text Int64
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Integer where parseParam :: Text -> Either Text Integer
parseParam = Text -> Either Text Integer
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Word where parseParam :: Text -> Either Text Word
parseParam = Text -> Either Text Word
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Word8 where parseParam :: Text -> Either Text Word8
parseParam = Text -> Either Text Word8
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Word16 where parseParam :: Text -> Either Text Word16
parseParam = Text -> Either Text Word16
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Word32 where parseParam :: Text -> Either Text Word32
parseParam = Text -> Either Text Word32
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Word64 where parseParam :: Text -> Either Text Word64
parseParam = Text -> Either Text Word64
forall a. Read a => Text -> Either Text a
readEither

instance ParsableParam Natural where parseParam :: Text -> Either Text Natural
parseParam = Text -> Either Text Natural
forall a. Read a => Text -> Either Text a
readEither

-- | Useful for creating 'ParsableParam' instances for things that already implement 'Read'.
readEither :: Read a => Text -> Either Text a
readEither :: Text -> Either Text 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 Text a
forall a b. b -> Either a b
Right a
x
  [] -> Text -> Either Text a
forall a b. a -> Either a b
Left Text
"readEither: no parse"
  [a]
_ -> Text -> Either Text a
forall a b. a -> Either a b
Left Text
"readEither: ambiguous parse"