Types.hs

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
      { preqBody :: Maybe ParsedBody,
        preqCookieParams :: [Param],
        preqPathParams :: [Param],
        preqQueryParams :: [Param]
      }

data ResponderOptions
  = ResponderOptions
      { optsMaxBodySize :: Word64,
        optsParseBody :: ParseRequestBodyOptions
      }

data ParsedBody
  = FormBody ([Param], [File BL.ByteString])
  | JSONBody JSON.Value

instance Functor ResponderM where
  fmap f (ResponderM g) = ResponderM $ \r -> mapRight (\(a, b) -> (f a, b)) `fmap` g r

instance Applicative ResponderM where
  pure a = ResponderM $ \r -> pure (Right (a, r))
  (<*>) = ap

instance Monad ResponderM where
  (ResponderM act) >>= fn = ResponderM $ \r -> do
    eres <- act r
    case eres of
      Left ract -> return (Left ract)
      Right (a, r') -> do
        let (ResponderM fres) = fn a
        fres r'

instance MonadIO ResponderM where
  liftIO act = ResponderM $ \r -> act >>= \a -> return (Right (a, r))

instance MonadThrow ResponderM where
  throwM = liftIO . throwIO

instance MonadCatch ResponderM where
  catch (ResponderM act) f = ResponderM $ \r -> do
    ea <- try (act r)
    case ea of
      Left e ->
        let (ResponderM h) = f e
         in h r
      Right a -> pure a

data HttpError = HttpError Status String
  deriving (Eq, Show)

instance Exception HttpError

type Param = (Text, Text)

data PathPattern = MatchPath (Request -> Maybe [Param])

instance IsString PathPattern where
  fromString s = MatchPath (matchPath (T.pack s))

matchPath :: Text -> Request -> Maybe [Param]
matchPath path req =
  go (splitPath path) (pathInfo req) (Just [])
  where
    splitPath = L.filter (not . T.null) . T.split (== '/')
    go (p : ps) (r : rs) m@(Just pms) =
      if not (T.null p) && T.head p == ':'
        then go ps rs (Just ((T.drop 1 p, r) : pms))
        else if p == r then go ps rs m else Nothing
    go [] [] pms = pms
    go _ _ _ = 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 t = mapM parseParam (T.split (== ',') t)

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

instance ParsableParam TL.Text where parseParam = Right . TL.fromStrict

instance ParsableParam T.Text where parseParam = Right

instance ParsableParam B.ByteString where parseParam = Right . encodeUtf8

instance ParsableParam BL.ByteString where parseParam = Right . BL.fromStrict . encodeUtf8

instance ParsableParam Char where
  parseParam t = case T.unpack t of
    [c] -> Right c
    _ -> Left $ HttpError status400 "parseParam Char: no parse"
  parseParamList = Right . T.unpack -- String

instance ParsableParam () where
  parseParam t =
    if T.null t
      then Right ()
      else Left $ HttpError status400 "parseParam Unit: no parse"

instance (ParsableParam a) => ParsableParam [a] where parseParam = parseParamList

instance ParsableParam Bool where
  parseParam t =
    if t' == T.toCaseFold "true"
      then Right True
      else
        if t' == T.toCaseFold "false"
          then Right False
          else Left $ HttpError status400 "parseParam Bool: no parse"
    where
      t' = T.toCaseFold t

instance ParsableParam Double where parseParam = readEither

instance ParsableParam Float where parseParam = readEither

instance ParsableParam Int where parseParam = readEither

instance ParsableParam Int8 where parseParam = readEither

instance ParsableParam Int16 where parseParam = readEither

instance ParsableParam Int32 where parseParam = readEither

instance ParsableParam Int64 where parseParam = readEither

instance ParsableParam Integer where parseParam = readEither

instance ParsableParam Word where parseParam = readEither

instance ParsableParam Word8 where parseParam = readEither

instance ParsableParam Word16 where parseParam = readEither

instance ParsableParam Word32 where parseParam = readEither

instance ParsableParam Word64 where parseParam = readEither

instance ParsableParam Natural where parseParam = readEither

-- | Useful for creating 'ParsableParam' instances for things that already implement 'Read'.
readEither :: Read a => Text -> Either HttpError a
readEither t = case [x | (x, "") <- reads (T.unpack t)] of
  [x] -> Right x
  [] -> Left $ HttpError status400 "readEither: no parse"
  _ -> Left $ HttpError status400 "readEither: ambiguous parse"

data HTTP2Exception = HTTP2Exception ErrorCode
  deriving (Show, Typeable)

instance Exception HTTP2Exception