{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- | Okapi is a micro web framework.
module Okapi
  ( -- * Parsing
    -- $parsers
    MonadOkapi,
    OkapiT (..),
    Failure (..),
    State (..),
    Request,
    Method,
    Path,
    Query,
    QueryItem (..),
    QueryValue (..),
    Body,
    Headers,
    Header,
    HeaderName,
    Okapi.Cookie,
    Crumb,

    -- ** Request Parsers
    request,
    requestEnd,

    -- *** Method Parsers
    -- $methodParsers
    method,
    methodGET,
    methodPOST,
    methodHEAD,
    methodPUT,
    methodPATCH,
    methodDELETE,
    methodOPTIONS,
    methodTRACE,
    methodCONNECT,
    methodEnd,

    -- *** Path Parsers
    -- $pathParsers
    path,
    pathParam,
    pathEnd,

    -- *** Query Parsers
    -- $queryParsers
    query,
    queryValue,
    queryFlag,
    queryParam,
    queryList,
    queryEnd,

    -- *** Body Parsers
    -- $bodyParsers
    body,
    bodyJSON,
    bodyForm,
    bodyEnd,

    -- *** Header Parsers
    -- $headerParsers
    headers,
    header,
    basicAuth,
    headersEnd,
    cookie,
    cookieCrumb,
    cookieEnd,

    -- ** Vault Parsers
    -- $vaultParsers
    vaultLookup,
    vaultInsert,
    vaultDelete,
    vaultAdjust,
    vaultWipe,

    -- ** Combinators
    -- $combinators
    is,
    satisfies,
    Okapi.look,
    module Combinators,

    -- ** Failure
    -- $failure
    next,
    throw,
    (<!>),
    guardThrow,

    -- * Responding
    -- $responding
    Handler (..),
    Response (..),
    Status,
    ResponseBody (..),

    -- ** Values
    ok,
    notFound,
    redirect,
    forbidden,
    internalServerError,

    -- ** Setters
    setStatus,
    setHeaders,
    setHeader,
    addHeader,
    addSetCookie,
    setBody,
    setBodyRaw,
    setBodyFile,
    setBodyEventSource,
    setPlaintext,
    setHTML,
    setJSON,

    -- ** Special
    static,

    -- * Middleware
    -- $middleware
    Middleware (..),
    applyMiddlewares,
    scope,
    clearHeadersMiddleware,
    prefixPathMiddleware,

    -- * Routing
    -- $routing
    Router (..),
    route,
    pattern PathParam,
    pattern GET,
    pattern POST,
    pattern DELETE,
    pattern PUT,
    pattern PATCH,
    pattern IsQueryParam,
    pattern HasQueryFlag,
    viewQuery,
    viewQueryParam,

    -- * Relative URLs
    -- $relativeURLs
    RelURL (..),
    renderRelURL,
    renderPath,
    renderQuery,
    parseRelURL,

    -- * Testing
    -- $testing
    testParser,
    testParserPure,
    testParserIO,
    assert,
    assert200,
    assert404,
    assert500,

    -- * WAI
    -- $wai
    run,
    serve,
    serveTLS,
    serveWebsockets,
    serveWebsocketsTLS,
    app,
    websocketsApp,
    testRunSession,
    testWithSession,
    testRequest,

    -- * Utilities

    -- ** Server Sent Events
    -- $serverSentEvents
    Event (..),
    ToSSE (..),
    EventSource,
    newEventSource,
    sendValue,
    sendEvent,

    -- ** Sessions
    Session (..),
    HasSession (..),
    session,
    sessionLookup,
    sessionInsert,
    sessionDelete,
    sessionClear,
    withSession,
  )
where

import qualified Control.Applicative as Applicative
import qualified Control.Concurrent as Concurrent
import qualified Control.Concurrent.Chan.Unagi as Unagi
import qualified Control.Monad as Monad
import qualified Control.Monad.Combinators as Combinators
import qualified Control.Monad.Combinators.NonEmpty as Combinators.NonEmpty
import qualified Control.Monad.Except as Except
import qualified Control.Monad.IO.Class as IO
import qualified Control.Monad.Identity as Identity
import qualified Control.Monad.Morph as Morph
import qualified Control.Monad.Reader as Reader
import qualified Control.Monad.State as State
import qualified Control.Monad.Trans.Except as ExceptT
import qualified Control.Monad.Trans.State.Strict as StateT
import qualified Control.Monad.Zip as Zip
import qualified Crypto.Hash as Crypto
import qualified Crypto.MAC.HMAC as HMAC
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encoding as Aeson
import qualified Data.Attoparsec.Text as Atto
import qualified Data.Bifunctor as Bifunctor
import qualified Data.ByteArray as Memory
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BS
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Either.Extra as Either
import qualified Data.Foldable as Foldable
import qualified Data.Function as Function
import qualified Data.Functor as Functor
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.String as String
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Encoding.Base64 as Text
import qualified Data.Vault.Lazy as Vault
import qualified GHC.Natural as Natural
import qualified Network.HTTP.Types as HTTP
import qualified Network.Socket as Socket
import qualified Network.Wai as WAI
import qualified Network.Wai.EventSource as WAI
import qualified Network.Wai.Handler.Warp as WAI
import qualified Network.Wai.Handler.WarpTLS as WAI
import qualified Network.Wai.Handler.WebSockets as WAI
import qualified Network.Wai.Handler.WebSockets as WebSockets
import qualified Network.Wai.Internal as WAI
import qualified Network.Wai.Middleware.Gzip as WAI
import qualified Network.Wai.Test as WAI
import qualified Network.WebSockets as WebSockets
import qualified Web.Cookie as Web
import qualified Web.FormUrlEncoded as Web
import qualified Web.HttpApiData as Web

-- $parserTypes
--
-- The types are as follows

-- | A type constraint representing monads that have the ability to parse an HTTP request.
type MonadOkapi m =
  ( Functor m,
    Applicative m,
    Applicative.Alternative m,
    Monad m,
    Monad.MonadPlus m,
    Except.MonadError Failure m,
    State.MonadState State m
  )

-- | A concrete implementation of the @MonadOkapi@ type constraint.
newtype OkapiT m a = OkapiT {OkapiT m a -> ExceptT Failure (StateT State m) a
unOkapiT :: Except.ExceptT Failure (State.StateT State m) a}
  deriving newtype
    ( Except.MonadError Failure,
      State.MonadState State
    )

instance Functor m => Functor (OkapiT m) where
  fmap :: (a -> b) -> OkapiT m a -> OkapiT m b
  fmap :: (a -> b) -> OkapiT m a -> OkapiT m b
fmap a -> b
f OkapiT m a
okapiT =
    ExceptT Failure (StateT State m) b -> OkapiT m b
forall (m :: * -> *) a.
ExceptT Failure (StateT State m) a -> OkapiT m a
OkapiT (ExceptT Failure (StateT State m) b -> OkapiT m b)
-> ((State -> m (Either Failure b, State))
    -> ExceptT Failure (StateT State m) b)
-> (State -> m (Either Failure b, State))
-> OkapiT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure b)
-> ExceptT Failure (StateT State m) b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (StateT State m (Either Failure b)
 -> ExceptT Failure (StateT State m) b)
-> ((State -> m (Either Failure b, State))
    -> StateT State m (Either Failure b))
-> (State -> m (Either Failure b, State))
-> ExceptT Failure (StateT State m) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> m (Either Failure b, State))
-> StateT State m (Either Failure b)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((State -> m (Either Failure b, State)) -> OkapiT m b)
-> (State -> m (Either Failure b, State)) -> OkapiT m b
forall a b. (a -> b) -> a -> b
$
      ( ((Either Failure a, State) -> (Either Failure b, State))
-> m (Either Failure a, State) -> m (Either Failure b, State)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ ~(Either Failure a
a, State
s') -> (a -> b
f (a -> b) -> Either Failure a -> Either Failure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Failure a
a, State
s'))
          (m (Either Failure a, State) -> m (Either Failure b, State))
-> (State -> m (Either Failure a, State))
-> State
-> m (Either Failure b, State)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure a)
-> State -> m (Either Failure a, State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (ExceptT Failure (StateT State m) a
-> StateT State m (Either Failure a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT Failure (StateT State m) a
 -> StateT State m (Either Failure a))
-> ExceptT Failure (StateT State m) a
-> StateT State m (Either Failure a)
forall a b. (a -> b) -> a -> b
$ OkapiT m a -> ExceptT Failure (StateT State m) a
forall (m :: * -> *) a.
OkapiT m a -> ExceptT Failure (StateT State m) a
unOkapiT OkapiT m a
okapiT)
      )
  {-# INLINE fmap #-}

instance Monad m => Applicative (OkapiT m) where
  pure :: a -> OkapiT m a
pure a
x = ExceptT Failure (StateT State m) a -> OkapiT m a
forall (m :: * -> *) a.
ExceptT Failure (StateT State m) a -> OkapiT m a
OkapiT (ExceptT Failure (StateT State m) a -> OkapiT m a)
-> ((State -> m (Either Failure a, State))
    -> ExceptT Failure (StateT State m) a)
-> (State -> m (Either Failure a, State))
-> OkapiT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure a)
-> ExceptT Failure (StateT State m) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (StateT State m (Either Failure a)
 -> ExceptT Failure (StateT State m) a)
-> ((State -> m (Either Failure a, State))
    -> StateT State m (Either Failure a))
-> (State -> m (Either Failure a, State))
-> ExceptT Failure (StateT State m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> m (Either Failure a, State))
-> StateT State m (Either Failure a)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((State -> m (Either Failure a, State)) -> OkapiT m a)
-> (State -> m (Either Failure a, State)) -> OkapiT m a
forall a b. (a -> b) -> a -> b
$ \State
s -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either Failure a
forall a b. b -> Either a b
Right a
x, State
s)
  {-# INLINEABLE pure #-}
  (OkapiT (Except.ExceptT (State.StateT State -> m (Either Failure (a -> b), State)
mf))) <*> :: OkapiT m (a -> b) -> OkapiT m a -> OkapiT m b
<*> (OkapiT (Except.ExceptT (State.StateT State -> m (Either Failure a, State)
mx))) = ExceptT Failure (StateT State m) b -> OkapiT m b
forall (m :: * -> *) a.
ExceptT Failure (StateT State m) a -> OkapiT m a
OkapiT (ExceptT Failure (StateT State m) b -> OkapiT m b)
-> ((State -> m (Either Failure b, State))
    -> ExceptT Failure (StateT State m) b)
-> (State -> m (Either Failure b, State))
-> OkapiT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure b)
-> ExceptT Failure (StateT State m) b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (StateT State m (Either Failure b)
 -> ExceptT Failure (StateT State m) b)
-> ((State -> m (Either Failure b, State))
    -> StateT State m (Either Failure b))
-> (State -> m (Either Failure b, State))
-> ExceptT Failure (StateT State m) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> m (Either Failure b, State))
-> StateT State m (Either Failure b)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((State -> m (Either Failure b, State)) -> OkapiT m b)
-> (State -> m (Either Failure b, State)) -> OkapiT m b
forall a b. (a -> b) -> a -> b
$ \State
s -> do
    ~(Either Failure (a -> b)
eitherF, State
s') <- State -> m (Either Failure (a -> b), State)
mf State
s
    case Either Failure (a -> b)
eitherF of
      Left Failure
error -> (Either Failure b, State) -> m (Either Failure b, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure b
forall a b. a -> Either a b
Left Failure
error, State
s)
      Right a -> b
f -> do
        ~(Either Failure a
eitherX, State
s'') <- State -> m (Either Failure a, State)
mx State
s'
        case Either Failure a
eitherX of
          Left Failure
error' -> (Either Failure b, State) -> m (Either Failure b, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure b
forall a b. a -> Either a b
Left Failure
error', State
s')
          Right a
x -> (Either Failure b, State) -> m (Either Failure b, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either Failure b
forall a b. b -> Either a b
Right (b -> Either Failure b) -> b -> Either Failure b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x, State
s'')
  {-# INLINEABLE (<*>) #-}
  OkapiT m a
m *> :: OkapiT m a -> OkapiT m b -> OkapiT m b
*> OkapiT m b
k = OkapiT m a
m OkapiT m a -> OkapiT m b -> OkapiT m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OkapiT m b
k
  {-# INLINE (*>) #-}

instance Monad m => Applicative.Alternative (OkapiT m) where
  empty :: OkapiT m a
empty = ExceptT Failure (StateT State m) a -> OkapiT m a
forall (m :: * -> *) a.
ExceptT Failure (StateT State m) a -> OkapiT m a
OkapiT (ExceptT Failure (StateT State m) a -> OkapiT m a)
-> ((State -> m (Either Failure a, State))
    -> ExceptT Failure (StateT State m) a)
-> (State -> m (Either Failure a, State))
-> OkapiT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure a)
-> ExceptT Failure (StateT State m) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (StateT State m (Either Failure a)
 -> ExceptT Failure (StateT State m) a)
-> ((State -> m (Either Failure a, State))
    -> StateT State m (Either Failure a))
-> (State -> m (Either Failure a, State))
-> ExceptT Failure (StateT State m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> m (Either Failure a, State))
-> StateT State m (Either Failure a)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((State -> m (Either Failure a, State)) -> OkapiT m a)
-> (State -> m (Either Failure a, State)) -> OkapiT m a
forall a b. (a -> b) -> a -> b
$ \State
s -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure a
forall a b. a -> Either a b
Left Failure
Skip, State
s)
  {-# INLINE empty #-}
  (OkapiT (Except.ExceptT (State.StateT State -> m (Either Failure a, State)
mx))) <|> :: OkapiT m a -> OkapiT m a -> OkapiT m a
<|> (OkapiT (Except.ExceptT (State.StateT State -> m (Either Failure a, State)
my))) = ExceptT Failure (StateT State m) a -> OkapiT m a
forall (m :: * -> *) a.
ExceptT Failure (StateT State m) a -> OkapiT m a
OkapiT (ExceptT Failure (StateT State m) a -> OkapiT m a)
-> ((State -> m (Either Failure a, State))
    -> ExceptT Failure (StateT State m) a)
-> (State -> m (Either Failure a, State))
-> OkapiT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure a)
-> ExceptT Failure (StateT State m) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (StateT State m (Either Failure a)
 -> ExceptT Failure (StateT State m) a)
-> ((State -> m (Either Failure a, State))
    -> StateT State m (Either Failure a))
-> (State -> m (Either Failure a, State))
-> ExceptT Failure (StateT State m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> m (Either Failure a, State))
-> StateT State m (Either Failure a)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((State -> m (Either Failure a, State)) -> OkapiT m a)
-> (State -> m (Either Failure a, State)) -> OkapiT m a
forall a b. (a -> b) -> a -> b
$ \State
s -> do
    (Either Failure a
eitherX, State
stateX) <- State -> m (Either Failure a, State)
mx State
s
    case Either Failure a
eitherX of
      Left Failure
Skip -> do
        (Either Failure a
eitherY, State
stateY) <- State -> m (Either Failure a, State)
my State
s
        case Either Failure a
eitherY of
          Left Failure
Skip -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure a
forall a b. a -> Either a b
Left Failure
Skip, State
s)
          Left error :: Failure
error@(Error Response
_) -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure a
forall a b. a -> Either a b
Left Failure
error, State
s)
          Right a
y -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either Failure a
forall a b. b -> Either a b
Right a
y, State
stateY)
      Left error :: Failure
error@(Error Response
_) -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure a
forall a b. a -> Either a b
Left Failure
error, State
s)
      Right a
x -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either Failure a
forall a b. b -> Either a b
Right a
x, State
stateX)
  {-# INLINEABLE (<|>) #-}

instance Monad m => Monad (OkapiT m) where
  return :: a -> OkapiT m a
return = a -> OkapiT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINEABLE return #-}
  (OkapiT (Except.ExceptT (State.StateT State -> m (Either Failure a, State)
mx))) >>= :: OkapiT m a -> (a -> OkapiT m b) -> OkapiT m b
>>= a -> OkapiT m b
f = ExceptT Failure (StateT State m) b -> OkapiT m b
forall (m :: * -> *) a.
ExceptT Failure (StateT State m) a -> OkapiT m a
OkapiT (ExceptT Failure (StateT State m) b -> OkapiT m b)
-> ((State -> m (Either Failure b, State))
    -> ExceptT Failure (StateT State m) b)
-> (State -> m (Either Failure b, State))
-> OkapiT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure b)
-> ExceptT Failure (StateT State m) b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (StateT State m (Either Failure b)
 -> ExceptT Failure (StateT State m) b)
-> ((State -> m (Either Failure b, State))
    -> StateT State m (Either Failure b))
-> (State -> m (Either Failure b, State))
-> ExceptT Failure (StateT State m) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> m (Either Failure b, State))
-> StateT State m (Either Failure b)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((State -> m (Either Failure b, State)) -> OkapiT m b)
-> (State -> m (Either Failure b, State)) -> OkapiT m b
forall a b. (a -> b) -> a -> b
$ \State
s -> do
    ~(Either Failure a
eitherX, State
s') <- State -> m (Either Failure a, State)
mx State
s
    case Either Failure a
eitherX of
      Left Failure
error -> (Either Failure b, State) -> m (Either Failure b, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure b
forall a b. a -> Either a b
Left Failure
error, State
s)
      Right a
x -> do
        ~(Either Failure b
eitherResult, State
s'') <- StateT State m (Either Failure b)
-> State -> m (Either Failure b, State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (ExceptT Failure (StateT State m) b
-> StateT State m (Either Failure b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT Failure (StateT State m) b
 -> StateT State m (Either Failure b))
-> ExceptT Failure (StateT State m) b
-> StateT State m (Either Failure b)
forall a b. (a -> b) -> a -> b
$ OkapiT m b -> ExceptT Failure (StateT State m) b
forall (m :: * -> *) a.
OkapiT m a -> ExceptT Failure (StateT State m) a
unOkapiT (OkapiT m b -> ExceptT Failure (StateT State m) b)
-> OkapiT m b -> ExceptT Failure (StateT State m) b
forall a b. (a -> b) -> a -> b
$ a -> OkapiT m b
f a
x) State
s'
        case Either Failure b
eitherResult of
          Left Failure
error' -> (Either Failure b, State) -> m (Either Failure b, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure b
forall a b. a -> Either a b
Left Failure
error', State
s')
          Right b
res -> (Either Failure b, State) -> m (Either Failure b, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either Failure b
forall a b. b -> Either a b
Right b
res, State
s'')
  {-# INLINEABLE (>>=) #-}

instance Monad m => Monad.MonadPlus (OkapiT m) where
  mzero :: OkapiT m a
mzero = ExceptT Failure (StateT State m) a -> OkapiT m a
forall (m :: * -> *) a.
ExceptT Failure (StateT State m) a -> OkapiT m a
OkapiT (ExceptT Failure (StateT State m) a -> OkapiT m a)
-> ((State -> m (Either Failure a, State))
    -> ExceptT Failure (StateT State m) a)
-> (State -> m (Either Failure a, State))
-> OkapiT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure a)
-> ExceptT Failure (StateT State m) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (StateT State m (Either Failure a)
 -> ExceptT Failure (StateT State m) a)
-> ((State -> m (Either Failure a, State))
    -> StateT State m (Either Failure a))
-> (State -> m (Either Failure a, State))
-> ExceptT Failure (StateT State m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> m (Either Failure a, State))
-> StateT State m (Either Failure a)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((State -> m (Either Failure a, State)) -> OkapiT m a)
-> (State -> m (Either Failure a, State)) -> OkapiT m a
forall a b. (a -> b) -> a -> b
$ \State
s -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure a
forall a b. a -> Either a b
Left Failure
Skip, State
s)
  {-# INLINE mzero #-}
  (OkapiT (Except.ExceptT (State.StateT State -> m (Either Failure a, State)
mx))) mplus :: OkapiT m a -> OkapiT m a -> OkapiT m a
`mplus` (OkapiT (Except.ExceptT (State.StateT State -> m (Either Failure a, State)
my))) = ExceptT Failure (StateT State m) a -> OkapiT m a
forall (m :: * -> *) a.
ExceptT Failure (StateT State m) a -> OkapiT m a
OkapiT (ExceptT Failure (StateT State m) a -> OkapiT m a)
-> ((State -> m (Either Failure a, State))
    -> ExceptT Failure (StateT State m) a)
-> (State -> m (Either Failure a, State))
-> OkapiT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure a)
-> ExceptT Failure (StateT State m) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (StateT State m (Either Failure a)
 -> ExceptT Failure (StateT State m) a)
-> ((State -> m (Either Failure a, State))
    -> StateT State m (Either Failure a))
-> (State -> m (Either Failure a, State))
-> ExceptT Failure (StateT State m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> m (Either Failure a, State))
-> StateT State m (Either Failure a)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((State -> m (Either Failure a, State)) -> OkapiT m a)
-> (State -> m (Either Failure a, State)) -> OkapiT m a
forall a b. (a -> b) -> a -> b
$ \State
s -> do
    (Either Failure a
eitherX, State
stateX) <- State -> m (Either Failure a, State)
mx State
s
    case Either Failure a
eitherX of
      Left Failure
Skip -> do
        (Either Failure a
eitherY, State
stateY) <- State -> m (Either Failure a, State)
my State
s
        case Either Failure a
eitherY of
          Left Failure
Skip -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure a
forall a b. a -> Either a b
Left Failure
Skip, State
s)
          Left error :: Failure
error@(Error Response
_) -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure a
forall a b. a -> Either a b
Left Failure
error, State
s)
          Right a
y -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either Failure a
forall a b. b -> Either a b
Right a
y, State
stateY)
      Left error :: Failure
error@(Error Response
_) -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure -> Either Failure a
forall a b. a -> Either a b
Left Failure
error, State
s)
      Right a
x -> (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either Failure a
forall a b. b -> Either a b
Right a
x, State
stateX)
  {-# INLINEABLE mplus #-}

instance Reader.MonadReader r m => Reader.MonadReader r (OkapiT m) where
  ask :: OkapiT m r
ask = m r -> OkapiT m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Morph.lift m r
forall r (m :: * -> *). MonadReader r m => m r
Reader.ask
  local :: (r -> r) -> OkapiT m a -> OkapiT m a
local = (m (Either Failure a, State) -> m (Either Failure a, State))
-> OkapiT m a -> OkapiT m a
forall a (n :: * -> *) b.
(m (Either Failure a, State) -> n (Either Failure b, State))
-> OkapiT m a -> OkapiT n b
mapOkapiT ((m (Either Failure a, State) -> m (Either Failure a, State))
 -> OkapiT m a -> OkapiT m a)
-> ((r -> r)
    -> m (Either Failure a, State) -> m (Either Failure a, State))
-> (r -> r)
-> OkapiT m a
-> OkapiT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> r)
-> m (Either Failure a, State) -> m (Either Failure a, State)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
Reader.local
    where
      mapOkapiT :: (m (Either Failure a, State) -> n (Either Failure b, State)) -> OkapiT m a -> OkapiT n b
      mapOkapiT :: (m (Either Failure a, State) -> n (Either Failure b, State))
-> OkapiT m a -> OkapiT n b
mapOkapiT m (Either Failure a, State) -> n (Either Failure b, State)
f OkapiT m a
okapiT = ExceptT Failure (StateT State n) b -> OkapiT n b
forall (m :: * -> *) a.
ExceptT Failure (StateT State m) a -> OkapiT m a
OkapiT (ExceptT Failure (StateT State n) b -> OkapiT n b)
-> ((State -> n (Either Failure b, State))
    -> ExceptT Failure (StateT State n) b)
-> (State -> n (Either Failure b, State))
-> OkapiT n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State n (Either Failure b)
-> ExceptT Failure (StateT State n) b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (StateT State n (Either Failure b)
 -> ExceptT Failure (StateT State n) b)
-> ((State -> n (Either Failure b, State))
    -> StateT State n (Either Failure b))
-> (State -> n (Either Failure b, State))
-> ExceptT Failure (StateT State n) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> n (Either Failure b, State))
-> StateT State n (Either Failure b)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((State -> n (Either Failure b, State)) -> OkapiT n b)
-> (State -> n (Either Failure b, State)) -> OkapiT n b
forall a b. (a -> b) -> a -> b
$ m (Either Failure a, State) -> n (Either Failure b, State)
f (m (Either Failure a, State) -> n (Either Failure b, State))
-> (State -> m (Either Failure a, State))
-> State
-> n (Either Failure b, State)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure a)
-> State -> m (Either Failure a, State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (ExceptT Failure (StateT State m) a
-> StateT State m (Either Failure a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT Failure (StateT State m) a
 -> StateT State m (Either Failure a))
-> ExceptT Failure (StateT State m) a
-> StateT State m (Either Failure a)
forall a b. (a -> b) -> a -> b
$ OkapiT m a -> ExceptT Failure (StateT State m) a
forall (m :: * -> *) a.
OkapiT m a -> ExceptT Failure (StateT State m) a
unOkapiT OkapiT m a
okapiT)
  reader :: (r -> a) -> OkapiT m a
reader = m a -> OkapiT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Morph.lift (m a -> OkapiT m a) -> ((r -> a) -> m a) -> (r -> a) -> OkapiT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> a) -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
Reader.reader

instance IO.MonadIO m => IO.MonadIO (OkapiT m) where
  liftIO :: IO a -> OkapiT m a
liftIO = m a -> OkapiT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Morph.lift (m a -> OkapiT m a) -> (IO a -> m a) -> IO a -> OkapiT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO 

instance Morph.MonadTrans OkapiT where
  lift :: Monad m => m a -> OkapiT m a
  lift :: m a -> OkapiT m a
lift m a
action = ExceptT Failure (StateT State m) a -> OkapiT m a
forall (m :: * -> *) a.
ExceptT Failure (StateT State m) a -> OkapiT m a
OkapiT (ExceptT Failure (StateT State m) a -> OkapiT m a)
-> ((State -> m (Either Failure a, State))
    -> ExceptT Failure (StateT State m) a)
-> (State -> m (Either Failure a, State))
-> OkapiT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure a)
-> ExceptT Failure (StateT State m) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (StateT State m (Either Failure a)
 -> ExceptT Failure (StateT State m) a)
-> ((State -> m (Either Failure a, State))
    -> StateT State m (Either Failure a))
-> (State -> m (Either Failure a, State))
-> ExceptT Failure (StateT State m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> m (Either Failure a, State))
-> StateT State m (Either Failure a)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((State -> m (Either Failure a, State)) -> OkapiT m a)
-> (State -> m (Either Failure a, State)) -> OkapiT m a
forall a b. (a -> b) -> a -> b
$ \State
s -> do
    a
result <- m a
action
    (Either Failure a, State) -> m (Either Failure a, State)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either Failure a
forall a b. b -> Either a b
Right a
result, State
s)

instance Morph.MFunctor OkapiT where
  hoist :: Monad m => (forall a. m a -> n a) -> OkapiT m b -> OkapiT n b
  hoist :: (forall a. m a -> n a) -> OkapiT m b -> OkapiT n b
hoist forall a. m a -> n a
nat OkapiT m b
okapiT = ExceptT Failure (StateT State n) b -> OkapiT n b
forall (m :: * -> *) a.
ExceptT Failure (StateT State m) a -> OkapiT m a
OkapiT (ExceptT Failure (StateT State n) b -> OkapiT n b)
-> ((State -> n (Either Failure b, State))
    -> ExceptT Failure (StateT State n) b)
-> (State -> n (Either Failure b, State))
-> OkapiT n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State n (Either Failure b)
-> ExceptT Failure (StateT State n) b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (StateT State n (Either Failure b)
 -> ExceptT Failure (StateT State n) b)
-> ((State -> n (Either Failure b, State))
    -> StateT State n (Either Failure b))
-> (State -> n (Either Failure b, State))
-> ExceptT Failure (StateT State n) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> n (Either Failure b, State))
-> StateT State n (Either Failure b)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.StateT ((State -> n (Either Failure b, State)) -> OkapiT n b)
-> (State -> n (Either Failure b, State)) -> OkapiT n b
forall a b. (a -> b) -> a -> b
$ (m (Either Failure b, State) -> n (Either Failure b, State)
forall a. m a -> n a
nat (m (Either Failure b, State) -> n (Either Failure b, State))
-> (State -> m (Either Failure b, State))
-> State
-> n (Either Failure b, State)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State m (Either Failure b)
-> State -> m (Either Failure b, State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (ExceptT Failure (StateT State m) b
-> StateT State m (Either Failure b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT Failure (StateT State m) b
 -> StateT State m (Either Failure b))
-> ExceptT Failure (StateT State m) b
-> StateT State m (Either Failure b)
forall a b. (a -> b) -> a -> b
$ OkapiT m b -> ExceptT Failure (StateT State m) b
forall (m :: * -> *) a.
OkapiT m a -> ExceptT Failure (StateT State m) a
unOkapiT OkapiT m b
okapiT))

-- | Represents the state of a parser. Set on every request to the Okapi server.
data State = State
  { State -> Request
stateRequest :: Request,
    State -> Vault
stateVault :: Vault.Vault
  }

-- | Represents the HTTP request being parsed.
data Request = Request
  { Request -> Method
requestMethod :: Method,
    Request -> Path
requestPath :: Path,
    Request -> Query
requestQuery :: Query,
    Request -> Body
requestBody :: Body,
    Request -> Headers
requestHeaders :: Headers
  }
  deriving (Request -> Request -> Bool
(Request -> Request -> Bool)
-> (Request -> Request -> Bool) -> Eq Request
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Request -> Request -> Bool
$c/= :: Request -> Request -> Bool
== :: Request -> Request -> Bool
$c== :: Request -> Request -> Bool
Eq, Int -> Request -> ShowS
[Request] -> ShowS
Request -> String
(Int -> Request -> ShowS)
-> (Request -> String) -> ([Request] -> ShowS) -> Show Request
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Request] -> ShowS
$cshowList :: [Request] -> ShowS
show :: Request -> String
$cshow :: Request -> String
showsPrec :: Int -> Request -> ShowS
$cshowsPrec :: Int -> Request -> ShowS
Show)

type Method = Maybe BS.ByteString

type Path = [Text.Text]

type Query = [QueryItem]

type QueryItem = (Text.Text, QueryValue)

data QueryValue = QueryParam Text.Text | QueryFlag deriving (QueryValue -> QueryValue -> Bool
(QueryValue -> QueryValue -> Bool)
-> (QueryValue -> QueryValue -> Bool) -> Eq QueryValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QueryValue -> QueryValue -> Bool
$c/= :: QueryValue -> QueryValue -> Bool
== :: QueryValue -> QueryValue -> Bool
$c== :: QueryValue -> QueryValue -> Bool
Eq, Int -> QueryValue -> ShowS
[QueryValue] -> ShowS
QueryValue -> String
(Int -> QueryValue -> ShowS)
-> (QueryValue -> String)
-> ([QueryValue] -> ShowS)
-> Show QueryValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QueryValue] -> ShowS
$cshowList :: [QueryValue] -> ShowS
show :: QueryValue -> String
$cshow :: QueryValue -> String
showsPrec :: Int -> QueryValue -> ShowS
$cshowsPrec :: Int -> QueryValue -> ShowS
Show) -- QueryList [Text]

type Body = LBS.ByteString

type Headers = [Header]

type Header = (HeaderName, BS.ByteString)

type HeaderName = HTTP.HeaderName

type Cookie = [Crumb]

type Crumb = (BS.ByteString, BS.ByteString)

-- $parsers
--
-- These are the parsers that you'll use to build you own app.

-- | Parses the entire request.
request :: MonadOkapi m => m Request
request :: m Request
request = Method -> Path -> Query -> Body -> Headers -> Request
Request (Method -> Path -> Query -> Body -> Headers -> Request)
-> m Method -> m (Path -> Query -> Body -> Headers -> Request)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Method
forall (m :: * -> *). MonadOkapi m => m Method
method m (Path -> Query -> Body -> Headers -> Request)
-> m Path -> m (Query -> Body -> Headers -> Request)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Path
forall (m :: * -> *). MonadOkapi m => m Path
path m (Query -> Body -> Headers -> Request)
-> m Query -> m (Body -> Headers -> Request)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Query
forall (m :: * -> *). MonadOkapi m => m Query
query m (Body -> Headers -> Request) -> m Body -> m (Headers -> Request)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Body
forall (m :: * -> *). MonadOkapi m => m Body
body m (Headers -> Request) -> m Headers -> m Request
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Headers
forall (m :: * -> *). MonadOkapi m => m Headers
headers

requestEnd :: MonadOkapi m => m ()
requestEnd :: m ()
requestEnd = do
  m ()
forall (m :: * -> *). MonadOkapi m => m ()
methodEnd
  m ()
forall (m :: * -> *). MonadOkapi m => m ()
pathEnd
  m ()
forall (m :: * -> *). MonadOkapi m => m ()
queryEnd
  m ()
forall (m :: * -> *). MonadOkapi m => m ()
headersEnd
  m ()
forall (m :: * -> *). MonadOkapi m => m ()
bodyEnd

-- $ methodParsers
--
-- These are parsers for parsing the HTTP request method.

method :: MonadOkapi m => m Method
method :: m Method
method = do
  Method
maybeMethod <- (State -> Method) -> m Method
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets (Request -> Method
requestMethod (Request -> Method) -> (State -> Request) -> State -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Request
stateRequest)
  case Method
maybeMethod of
    Method
Nothing -> Method -> m Method
forall (f :: * -> *) a. Applicative f => a -> f a
pure Method
forall a. Maybe a
Nothing
    method' :: Method
method'@(Just ByteString
_) -> do
      (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestMethod :: Method
requestMethod = Method
forall a. Maybe a
Nothing}})
      Method -> m Method
forall (f :: * -> *) a. Applicative f => a -> f a
pure Method
method'

methodGET :: MonadOkapi m => m ()
methodGET :: m ()
methodGET = m Method -> Method -> m ()
forall a (m :: * -> *). (Eq a, MonadOkapi m) => m a -> a -> m ()
is m Method
forall (m :: * -> *). MonadOkapi m => m Method
method (Method -> m ()) -> Method -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Method
forall a. a -> Maybe a
Just ByteString
HTTP.methodGet

methodPOST :: MonadOkapi m => m ()
methodPOST :: m ()
methodPOST = m Method -> Method -> m ()
forall a (m :: * -> *). (Eq a, MonadOkapi m) => m a -> a -> m ()
is m Method
forall (m :: * -> *). MonadOkapi m => m Method
method (Method -> m ()) -> Method -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Method
forall a. a -> Maybe a
Just ByteString
HTTP.methodPost

methodHEAD :: MonadOkapi m => m ()
methodHEAD :: m ()
methodHEAD = m Method -> Method -> m ()
forall a (m :: * -> *). (Eq a, MonadOkapi m) => m a -> a -> m ()
is m Method
forall (m :: * -> *). MonadOkapi m => m Method
method (Method -> m ()) -> Method -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Method
forall a. a -> Maybe a
Just ByteString
HTTP.methodHead

methodPUT :: MonadOkapi m => m ()
methodPUT :: m ()
methodPUT = m Method -> Method -> m ()
forall a (m :: * -> *). (Eq a, MonadOkapi m) => m a -> a -> m ()
is m Method
forall (m :: * -> *). MonadOkapi m => m Method
method (Method -> m ()) -> Method -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Method
forall a. a -> Maybe a
Just ByteString
HTTP.methodPut

methodDELETE :: MonadOkapi m => m ()
methodDELETE :: m ()
methodDELETE = m Method -> Method -> m ()
forall a (m :: * -> *). (Eq a, MonadOkapi m) => m a -> a -> m ()
is m Method
forall (m :: * -> *). MonadOkapi m => m Method
method (Method -> m ()) -> Method -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Method
forall a. a -> Maybe a
Just ByteString
HTTP.methodDelete

methodTRACE :: MonadOkapi m => m ()
methodTRACE :: m ()
methodTRACE = m Method -> Method -> m ()
forall a (m :: * -> *). (Eq a, MonadOkapi m) => m a -> a -> m ()
is m Method
forall (m :: * -> *). MonadOkapi m => m Method
method (Method -> m ()) -> Method -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Method
forall a. a -> Maybe a
Just ByteString
HTTP.methodTrace

methodCONNECT :: MonadOkapi m => m ()
methodCONNECT :: m ()
methodCONNECT = m Method -> Method -> m ()
forall a (m :: * -> *). (Eq a, MonadOkapi m) => m a -> a -> m ()
is m Method
forall (m :: * -> *). MonadOkapi m => m Method
method (Method -> m ()) -> Method -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Method
forall a. a -> Maybe a
Just ByteString
HTTP.methodConnect

methodOPTIONS :: MonadOkapi m => m ()
methodOPTIONS :: m ()
methodOPTIONS = m Method -> Method -> m ()
forall a (m :: * -> *). (Eq a, MonadOkapi m) => m a -> a -> m ()
is m Method
forall (m :: * -> *). MonadOkapi m => m Method
method (Method -> m ()) -> Method -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Method
forall a. a -> Maybe a
Just ByteString
HTTP.methodOptions

methodPATCH :: MonadOkapi m => m ()
methodPATCH :: m ()
methodPATCH = m Method -> Method -> m ()
forall a (m :: * -> *). (Eq a, MonadOkapi m) => m a -> a -> m ()
is m Method
forall (m :: * -> *). MonadOkapi m => m Method
method (Method -> m ()) -> Method -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Method
forall a. a -> Maybe a
Just ByteString
HTTP.methodPatch

methodEnd :: MonadOkapi m => m ()
methodEnd :: m ()
methodEnd = do
  Maybe Method
maybeMethod <- m Method -> m (Maybe Method)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Combinators.optional m Method
forall (m :: * -> *). MonadOkapi m => m Method
method
  case Maybe Method
maybeMethod of
    Maybe Method
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Method
_ -> m ()
forall (m :: * -> *) a. MonadOkapi m => m a
next

-- $pathParsers
--
-- These are the path parsers.

-- | Parses and discards mutiple path segments matching the values and order of the given @[Text]@ value
path :: MonadOkapi m => m [Text.Text]
path :: m Path
path = m Text -> m Path
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Combinators.many m Text
forall a (m :: * -> *). (FromHttpApiData a, MonadOkapi m) => m a
pathParam

-- | Parses and discards a single path segment matching the given @Text@ value
pathParam :: (Web.FromHttpApiData a, MonadOkapi m) => m a
pathParam :: m a
pathParam = do
  Maybe Text
maybePathSeg <- (State -> Maybe Text) -> m (Maybe Text)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets (Path -> Maybe Text
forall a. [a] -> Maybe a
safeHead (Path -> Maybe Text) -> (State -> Path) -> State -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Path
requestPath (Request -> Path) -> (State -> Request) -> State -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Request
stateRequest)
  case Maybe Text
maybePathSeg of
    Maybe Text
Nothing -> m a
forall (m :: * -> *) a. MonadOkapi m => m a
next
    Just Text
pathSeg -> do
      (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestPath :: Path
requestPath = Int -> Path -> Path
forall a. Int -> [a] -> [a]
Prelude.drop Int
1 (Path -> Path) -> Path -> Path
forall a b. (a -> b) -> a -> b
$ Request -> Path
requestPath (Request -> Path) -> Request -> Path
forall a b. (a -> b) -> a -> b
$ State -> Request
stateRequest State
state}})
      m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. MonadOkapi m => m a
next a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe a
forall a. FromHttpApiData a => Text -> Maybe a
Web.parseUrlPieceMaybe Text
pathSeg)
  where
    safeHead :: [a] -> Maybe a
    safeHead :: [a] -> Maybe a
safeHead [] = Maybe a
forall a. Maybe a
Nothing
    safeHead (a
x : [a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x

-- | Similar to `end` function in <https://github.com/purescript-contrib/purescript-routing/blob/main/GUIDE.md>
pathEnd :: MonadOkapi m => m ()
pathEnd :: m ()
pathEnd = do
  Path
currentPath <- m Path
forall (m :: * -> *). MonadOkapi m => m Path
path
  if Path -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null Path
currentPath
    then () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else m ()
forall (m :: * -> *) a. MonadOkapi m => m a
next

-- $queryParsers
--
-- These are the query parsers.

query :: MonadOkapi m => m Query
query :: m Query
query = do
  Query
query <- (State -> Query) -> m Query
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets (Request -> Query
requestQuery (Request -> Query) -> (State -> Request) -> State -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Request
stateRequest)
  (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestQuery :: Query
requestQuery = []}})
  Query -> m Query
forall (f :: * -> *) a. Applicative f => a -> f a
pure Query
query

queryValue :: MonadOkapi m => Text.Text -> m QueryValue
queryValue :: Text -> m QueryValue
queryValue Text
queryItemName = do
  Maybe (Text, QueryValue)
maybeQueryItem <- (State -> Maybe (Text, QueryValue)) -> m (Maybe (Text, QueryValue))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets (((Text, QueryValue) -> Bool) -> Query -> Maybe (Text, QueryValue)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Foldable.find (\(Text
queryItemName', QueryValue
_) -> Text
queryItemName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
queryItemName') (Query -> Maybe (Text, QueryValue))
-> (State -> Query) -> State -> Maybe (Text, QueryValue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Query
requestQuery (Request -> Query) -> (State -> Request) -> State -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Request
stateRequest)
  case Maybe (Text, QueryValue)
maybeQueryItem of
    Maybe (Text, QueryValue)
Nothing -> m QueryValue
forall (m :: * -> *) a. MonadOkapi m => m a
next
    Just queryItem :: (Text, QueryValue)
queryItem@(Text
_, QueryValue
queryValue) -> do
      (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestQuery :: Query
requestQuery = (Text, QueryValue) -> Query -> Query
forall a. Eq a => a -> [a] -> [a]
List.delete (Text, QueryValue)
queryItem (Query -> Query) -> Query -> Query
forall a b. (a -> b) -> a -> b
$ Request -> Query
requestQuery (Request -> Query) -> Request -> Query
forall a b. (a -> b) -> a -> b
$ State -> Request
stateRequest State
state}})
      QueryValue -> m QueryValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryValue
queryValue

-- | Parses the value of a query parameter with the given type and name
queryParam :: (Web.FromHttpApiData a, MonadOkapi m) => Text.Text -> m a
queryParam :: Text -> m a
queryParam Text
queryItemName = do
  QueryValue
queryItemValue <- Text -> m QueryValue
forall (m :: * -> *). MonadOkapi m => Text -> m QueryValue
queryValue Text
queryItemName
  case QueryValue
queryItemValue of
    QueryValue
QueryFlag -> m a
forall (m :: * -> *) a. MonadOkapi m => m a
next
    QueryParam Text
valueText -> m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. MonadOkapi m => m a
next a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe a
forall a. FromHttpApiData a => Text -> Maybe a
Web.parseQueryParamMaybe Text
valueText)

-- | Test for the existance of a query flag
queryFlag :: MonadOkapi m => Text.Text -> m ()
queryFlag :: Text -> m ()
queryFlag Text
queryItemName = do
  QueryValue
queryItemValue <- Text -> m QueryValue
forall (m :: * -> *). MonadOkapi m => Text -> m QueryValue
queryValue Text
queryItemName
  case QueryValue
queryItemValue of
    QueryValue
QueryFlag -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    QueryValue
_ -> m ()
forall (m :: * -> *) a. MonadOkapi m => m a
next

queryList :: (Web.FromHttpApiData a, MonadOkapi m) => Text.Text -> m (NonEmpty.NonEmpty a)
queryList :: Text -> m (NonEmpty a)
queryList = m a -> m (NonEmpty a)
forall (m :: * -> *) a. MonadPlus m => m a -> m (NonEmpty a)
Combinators.NonEmpty.some (m a -> m (NonEmpty a)) -> (Text -> m a) -> Text -> m (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m a
forall a (m :: * -> *).
(FromHttpApiData a, MonadOkapi m) =>
Text -> m a
queryParam

queryEnd :: MonadOkapi m => m ()
queryEnd :: m ()
queryEnd = do
  Query
currentQuery <- m Query
forall (m :: * -> *). MonadOkapi m => m Query
query
  if Query -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null Query
currentQuery
    then () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else m ()
forall (m :: * -> *) a. MonadOkapi m => m a
next

-- $bodyParsers

body :: MonadOkapi m => m Body
body :: m Body
body = do
  Body
currentBody <- (State -> Body) -> m Body
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets (Request -> Body
requestBody (Request -> Body) -> (State -> Request) -> State -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Request
stateRequest)
  if Body -> Bool
LBS.null Body
currentBody
    then m Body
forall (m :: * -> *) a. MonadOkapi m => m a
next
    else do
      (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestBody :: Body
requestBody = Body
""}})
      Body -> m Body
forall (f :: * -> *) a. Applicative f => a -> f a
pure Body
currentBody

-- TODO: Parse body in chunks abstraction?

bodyJSON :: (Aeson.FromJSON a, MonadOkapi m) => m a
bodyJSON :: m a
bodyJSON = do
  Body
lbs <- m Body
forall (m :: * -> *). MonadOkapi m => m Body
body
  m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. MonadOkapi m => m a
next a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Body -> Maybe a
forall a. FromJSON a => Body -> Maybe a
Aeson.decode Body
lbs)

bodyForm :: (Web.FromForm a, MonadOkapi m) => m a
bodyForm :: m a
bodyForm = do
  Body
lbs <- m Body
forall (m :: * -> *). MonadOkapi m => m Body
body
  m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. MonadOkapi m => m a
next a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> Maybe a
forall l r. Either l r -> Maybe r
eitherToMaybe (Either Text a -> Maybe a) -> Either Text a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Body -> Either Text a
forall a. FromForm a => Body -> Either Text a
Web.urlDecodeAsForm Body
lbs)
  where
    eitherToMaybe :: Either l r -> Maybe r
    eitherToMaybe :: Either l r -> Maybe r
eitherToMaybe Either l r
either = case Either l r
either of
      Left l
_ -> Maybe r
forall a. Maybe a
Nothing
      Right r
value -> r -> Maybe r
forall a. a -> Maybe a
Just r
value

-- TODO: Add abstraction for multipart forms

bodyEnd :: MonadOkapi m => m ()
bodyEnd :: m ()
bodyEnd = do
  Body
currentBody <- m Body
forall (m :: * -> *). MonadOkapi m => m Body
body
  if Body -> Bool
LBS.null Body
currentBody
    then () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else m ()
forall (m :: * -> *) a. MonadOkapi m => m a
next

-- $headerParsers
--
-- These are header parsers.

headers :: MonadOkapi m => m Headers
headers :: m Headers
headers = do
  Headers
headers <- (State -> Headers) -> m Headers
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets (Request -> Headers
requestHeaders (Request -> Headers) -> (State -> Request) -> State -> Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Request
stateRequest)
  (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestHeaders :: Headers
requestHeaders = []}})
  Headers -> m Headers
forall (f :: * -> *) a. Applicative f => a -> f a
pure Headers
headers

header :: MonadOkapi m => HTTP.HeaderName -> m Char8.ByteString
header :: HeaderName -> m ByteString
header HeaderName
headerName = do
  Maybe (HeaderName, ByteString)
maybeHeader <- (State -> Maybe (HeaderName, ByteString))
-> m (Maybe (HeaderName, ByteString))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets (((HeaderName, ByteString) -> Bool)
-> Headers -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Foldable.find (\(HeaderName
headerName', ByteString
_) -> HeaderName
headerName HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
headerName') (Headers -> Maybe (HeaderName, ByteString))
-> (State -> Headers) -> State -> Maybe (HeaderName, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Headers
requestHeaders (Request -> Headers) -> (State -> Request) -> State -> Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Request
stateRequest)
  case Maybe (HeaderName, ByteString)
maybeHeader of
    Maybe (HeaderName, ByteString)
Nothing -> m ByteString
forall (m :: * -> *) a. MonadOkapi m => m a
next
    Just header :: (HeaderName, ByteString)
header@(HeaderName
_, ByteString
headerValue) -> do
      (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestHeaders :: Headers
requestHeaders = (HeaderName, ByteString) -> Headers -> Headers
forall a. Eq a => a -> [a] -> [a]
List.delete (HeaderName, ByteString)
header (Headers -> Headers) -> Headers -> Headers
forall a b. (a -> b) -> a -> b
$ Request -> Headers
requestHeaders (Request -> Headers) -> Request -> Headers
forall a b. (a -> b) -> a -> b
$ State -> Request
stateRequest State
state}})
      ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
headerValue

headersEnd :: MonadOkapi m => m ()
headersEnd :: m ()
headersEnd = do
  Headers
currentHeaders <- m Headers
forall (m :: * -> *). MonadOkapi m => m Headers
headers
  if Headers -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null Headers
currentHeaders
    then () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else m ()
forall (m :: * -> *) a. MonadOkapi m => m a
next

cookie :: MonadOkapi m => m Cookie
cookie :: m Cookie
cookie = do
  ByteString
cookieValue <- HeaderName -> m ByteString
forall (m :: * -> *). MonadOkapi m => HeaderName -> m ByteString
header HeaderName
"Cookie"
  Cookie -> m Cookie
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cookie -> m Cookie) -> Cookie -> m Cookie
forall a b. (a -> b) -> a -> b
$ ByteString -> Cookie
Web.parseCookies ByteString
cookieValue

cookieCrumb :: MonadOkapi m => BS.ByteString -> m BS.ByteString
cookieCrumb :: ByteString -> m ByteString
cookieCrumb ByteString
name = do
  Cookie
cookieValue <- m Cookie
forall (m :: * -> *). MonadOkapi m => m Cookie
cookie
  case ByteString -> Cookie -> Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup ByteString
name Cookie
cookieValue of
    Method
Nothing -> m ByteString
forall (m :: * -> *) a. MonadOkapi m => m a
next
    Just ByteString
crumbValue -> do
      let crumb :: (ByteString, ByteString)
crumb = (ByteString
name, ByteString
crumbValue)
      -- TODO: Needs testing to see if state is restored properly
      (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestHeaders :: Headers
requestHeaders = (HeaderName
"Cookie", Body -> ByteString
LBS.toStrict (Body -> ByteString) -> Body -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> Body
Builder.toLazyByteString (Builder -> Body) -> Builder -> Body
forall a b. (a -> b) -> a -> b
$ Cookie -> Builder
Web.renderCookies (Cookie -> Builder) -> Cookie -> Builder
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> Cookie -> Cookie
forall a. Eq a => a -> [a] -> [a]
List.delete (ByteString, ByteString)
crumb Cookie
cookieValue) (HeaderName, ByteString) -> Headers -> Headers
forall a. a -> [a] -> [a]
: Request -> Headers
requestHeaders (State -> Request
stateRequest State
state)}})
      ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
crumbValue

cookieEnd :: MonadOkapi m => m ()
cookieEnd :: m ()
cookieEnd = do
  Cookie
currentCookie <- m Cookie
forall (m :: * -> *). MonadOkapi m => m Cookie
cookie
  if Cookie -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null Cookie
currentCookie
    then () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else m ()
forall (m :: * -> *) a. MonadOkapi m => m a
next

basicAuth :: MonadOkapi m => m (Text.Text, Text.Text)
basicAuth :: m (Text, Text)
basicAuth = do
  ByteString
authValue <- HeaderName -> m ByteString
forall (m :: * -> *). MonadOkapi m => HeaderName -> m ByteString
header HeaderName
"Authorization"
  case Text -> Path
Text.words (Text -> Path) -> Text -> Path
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeUtf8 ByteString
authValue of
    [Text
"Basic", Text
encodedCreds] ->
      case Text -> Either Text Text
Text.decodeBase64 Text
encodedCreds of
        Left Text
_ -> m (Text, Text)
forall (m :: * -> *) a. MonadOkapi m => m a
next
        Right Text
decodedCreds ->
          case (Char -> Bool) -> Text -> Path
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
decodedCreds of
            [Text
userID, Text
password] -> (Text, Text) -> m (Text, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
userID, Text
password)
            Path
_ -> m (Text, Text)
forall (m :: * -> *) a. MonadOkapi m => m a
next
    Path
_ -> m (Text, Text)
forall (m :: * -> *) a. MonadOkapi m => m a
next

-- $vaultParsers

vaultLookup :: MonadOkapi m => Vault.Key a -> m a
vaultLookup :: Key a -> m a
vaultLookup Key a
key = do
  Vault
vault <- (State -> Vault) -> m Vault
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Vault
stateVault
  m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. MonadOkapi m => m a
next a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key a -> Vault -> Maybe a
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key a
key Vault
vault)

vaultInsert :: MonadOkapi m => Vault.Key a -> a -> m ()
vaultInsert :: Key a -> a -> m ()
vaultInsert Key a
key a
value = do
  Vault
vault <- (State -> Vault) -> m Vault
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Vault
stateVault
  (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateVault :: Vault
stateVault = Key a -> a -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Vault.insert Key a
key a
value Vault
vault})

vaultDelete :: MonadOkapi m => Vault.Key a -> m ()
vaultDelete :: Key a -> m ()
vaultDelete Key a
key = do
  Vault
vault <- (State -> Vault) -> m Vault
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Vault
stateVault
  (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateVault :: Vault
stateVault = Key a -> Vault -> Vault
forall a. Key a -> Vault -> Vault
Vault.delete Key a
key Vault
vault})

vaultAdjust :: MonadOkapi m => (a -> a) -> Vault.Key a -> m ()
vaultAdjust :: (a -> a) -> Key a -> m ()
vaultAdjust a -> a
adjuster Key a
key = do
  Vault
vault <- (State -> Vault) -> m Vault
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Vault
stateVault
  (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateVault :: Vault
stateVault = (a -> a) -> Key a -> Vault -> Vault
forall a. (a -> a) -> Key a -> Vault -> Vault
Vault.adjust a -> a
adjuster Key a
key Vault
vault})

vaultWipe :: MonadOkapi m => m ()
vaultWipe :: m ()
vaultWipe = (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (\State
state -> State
state {stateVault :: Vault
stateVault = Vault
Vault.empty})

-- $combinators

is :: (Eq a, MonadOkapi m) => m a -> a -> m ()
is :: m a -> a -> m ()
is m a
action a
desired = m a -> (a -> Bool) -> m ()
forall a (m :: * -> *).
(Eq a, MonadOkapi m) =>
m a -> (a -> Bool) -> m ()
satisfies m a
action (a
desired a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==)

satisfies :: (Eq a, MonadOkapi m) => m a -> (a -> Bool) -> m ()
satisfies :: m a -> (a -> Bool) -> m ()
satisfies m a
action a -> Bool
predicate = do
  a
value <- m a
action
  if a -> Bool
predicate a
value
    then () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else m ()
forall (m :: * -> *) a. MonadOkapi m => m a
next

-- | Parses without modifying the state, even if it succeeds.
look :: MonadOkapi m => m a -> m a
look :: m a -> m a
look m a
parser = do
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  a
result <- m a
parser
  State -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put State
state
  a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

-- $error

-- | Represents the two variants of failure that can occur when parsing a HTTP request.
data Failure = Skip | Error Response

instance Show Failure where
  show :: Failure -> String
show Failure
Skip = String
"Skipped"
  show (Error Response
_) = String
"Error returned"

next :: MonadOkapi m => m a
next :: m a
next = Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip

throw :: MonadOkapi m => Response -> m a
throw :: Response -> m a
throw = Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError (Failure -> m a) -> (Response -> Failure) -> Response -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Failure
Error

(<!>) :: MonadOkapi m => m a -> m a -> m a
m a
parser1 <!> :: m a -> m a -> m a
<!> m a
parser2 = m a -> (Failure -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
Except.catchError m a
parser1 (m a -> Failure -> m a
forall a b. a -> b -> a
const m a
parser2)

guardThrow :: MonadOkapi m => Response -> Bool -> m ()
guardThrow :: Response -> Bool -> m ()
guardThrow Response
_ Bool
True = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
guardThrow Response
response Bool
False = Response -> m ()
forall (m :: * -> *) a. MonadOkapi m => Response -> m a
throw Response
response

-- $response

-- | Represents monadic actions that return a @Response@, for some @m@.
type Handler m = m Response

-- | Represents HTTP responses that can be returned by a parser.
data Response = Response
  { Response -> Status
responseStatus :: Status,
    Response -> Headers
responseHeaders :: Headers,
    Response -> ResponseBody
responseBody :: ResponseBody
  }

type Status = Natural.Natural

-- | Represents the body of an HTTP response.
data ResponseBody
  = ResponseBodyRaw LBS.ByteString
  | ResponseBodyFile FilePath
  | ResponseBodyEventSource EventSource

ok :: Response
ok :: Response
ok =
  let responseStatus :: Status
responseStatus = Status
200
      responseHeaders :: [a]
responseHeaders = []
      responseBody :: ResponseBody
responseBody = Body -> ResponseBody
ResponseBodyRaw Body
"OK"
   in Response :: Status -> Headers -> ResponseBody -> Response
Response {Status
Headers
ResponseBody
forall a. [a]
responseBody :: ResponseBody
responseHeaders :: forall a. [a]
responseStatus :: Status
responseBody :: ResponseBody
responseHeaders :: Headers
responseStatus :: Status
..}

notFound :: Response
notFound :: Response
notFound =
  let responseStatus :: Status
responseStatus = Status
404
      responseHeaders :: [a]
responseHeaders = []
      responseBody :: ResponseBody
responseBody = Body -> ResponseBody
ResponseBodyRaw Body
"Not Found"
   in Response :: Status -> Headers -> ResponseBody -> Response
Response {Status
Headers
ResponseBody
forall a. [a]
responseBody :: ResponseBody
responseHeaders :: forall a. [a]
responseStatus :: Status
responseBody :: ResponseBody
responseHeaders :: Headers
responseStatus :: Status
..}

redirect :: Status -> Text.Text -> Response
redirect :: Status -> Text -> Response
redirect Status
status Text
url =
  let responseStatus :: Status
responseStatus = Status
status
      responseHeaders :: Headers
responseHeaders = [(HeaderName
"Location", Text -> ByteString
Text.encodeUtf8 Text
url)]
      responseBody :: ResponseBody
responseBody = Body -> ResponseBody
ResponseBodyRaw Body
""
   in Response :: Status -> Headers -> ResponseBody -> Response
Response {Status
Headers
ResponseBody
responseBody :: ResponseBody
responseHeaders :: Headers
responseStatus :: Status
responseBody :: ResponseBody
responseHeaders :: Headers
responseStatus :: Status
..}

forbidden :: Response
forbidden :: Response
forbidden =
  let responseStatus :: Status
responseStatus = Status
403
      responseHeaders :: [a]
responseHeaders = []
      responseBody :: ResponseBody
responseBody = Body -> ResponseBody
ResponseBodyRaw Body
"Forbidden"
   in Response :: Status -> Headers -> ResponseBody -> Response
Response {Status
Headers
ResponseBody
forall a. [a]
responseBody :: ResponseBody
responseHeaders :: forall a. [a]
responseStatus :: Status
responseBody :: ResponseBody
responseHeaders :: Headers
responseStatus :: Status
..}

internalServerError :: Response
internalServerError :: Response
internalServerError =
  let responseStatus :: Status
responseStatus = Status
500
      responseHeaders :: [a]
responseHeaders = []
      responseBody :: ResponseBody
responseBody = Body -> ResponseBody
ResponseBodyRaw Body
"Internal Server Error"
   in Response :: Status -> Headers -> ResponseBody -> Response
Response {Status
Headers
ResponseBody
forall a. [a]
responseBody :: ResponseBody
responseHeaders :: forall a. [a]
responseStatus :: Status
responseBody :: ResponseBody
responseHeaders :: Headers
responseStatus :: Status
..}

-- RESPONSE SETTERS

setStatus :: Status -> Response -> Response
setStatus :: Status -> Response -> Response
setStatus Status
status Response
response = Response
response {responseStatus :: Status
responseStatus = Status
status}

setHeaders :: Headers -> Response -> Response
setHeaders :: Headers -> Response -> Response
setHeaders Headers
headers Response
response = Response
response {responseHeaders :: Headers
responseHeaders = Headers
headers}

setHeader :: Header -> Response -> Response
setHeader :: (HeaderName, ByteString) -> Response -> Response
setHeader (HeaderName, ByteString)
header response :: Response
response@Response {Status
Headers
ResponseBody
responseBody :: ResponseBody
responseHeaders :: Headers
responseStatus :: Status
responseBody :: Response -> ResponseBody
responseHeaders :: Response -> Headers
responseStatus :: Response -> Status
..} =
  Response
response {responseHeaders :: Headers
responseHeaders = (HeaderName, ByteString) -> Headers -> Headers
forall a b. Eq a => (a, b) -> [(a, b)] -> [(a, b)]
update (HeaderName, ByteString)
header Headers
responseHeaders}
  where
    update :: forall a b. Eq a => (a, b) -> [(a, b)] -> [(a, b)]
    update :: (a, b) -> [(a, b)] -> [(a, b)]
update (a, b)
pair [] = [(a, b)
pair]
    update pair :: (a, b)
pair@(a
key, b
value) (pair' :: (a, b)
pair'@(a
key', b
value') : [(a, b)]
ps) =
      if a
key a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
key'
        then (a, b)
pair (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
ps
        else (a, b)
pair' (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: (a, b) -> [(a, b)] -> [(a, b)]
forall a b. Eq a => (a, b) -> [(a, b)] -> [(a, b)]
update (a, b)
pair [(a, b)]
ps

addHeader :: Header -> Response -> Response
addHeader :: (HeaderName, ByteString) -> Response -> Response
addHeader (HeaderName, ByteString)
header Response
response = Response
response {responseHeaders :: Headers
responseHeaders = (HeaderName, ByteString)
header (HeaderName, ByteString) -> Headers -> Headers
forall a. a -> [a] -> [a]
: Response -> Headers
responseHeaders Response
response}

addSetCookie :: (BS.ByteString, BS.ByteString) -> Response -> Response
addSetCookie :: (ByteString, ByteString) -> Response -> Response
addSetCookie (ByteString
key, ByteString
value) Response
response =
  let setCookieValue :: ByteString
setCookieValue =
        Body -> ByteString
LBS.toStrict (Body -> ByteString) -> Body -> ByteString
forall a b. (a -> b) -> a -> b
$
          Builder -> Body
Builder.toLazyByteString (Builder -> Body) -> Builder -> Body
forall a b. (a -> b) -> a -> b
$
            SetCookie -> Builder
Web.renderSetCookie (SetCookie -> Builder) -> SetCookie -> Builder
forall a b. (a -> b) -> a -> b
$
              SetCookie
Web.defaultSetCookie -- TODO: Check that using default here is okay
                { setCookieName :: ByteString
Web.setCookieName = ByteString
key,
                  setCookieValue :: ByteString
Web.setCookieValue = ByteString
value,
                  setCookiePath :: Method
Web.setCookiePath = ByteString -> Method
forall a. a -> Maybe a
Just ByteString
"/"
                }
   in (HeaderName, ByteString) -> Response -> Response
addHeader (HeaderName
"Set-Cookie", ByteString
setCookieValue) Response
response

setBody :: ResponseBody -> Response -> Response
setBody :: ResponseBody -> Response -> Response
setBody ResponseBody
body Response
response = Response
response {responseBody :: ResponseBody
responseBody = ResponseBody
body}

setBodyRaw :: LBS.ByteString -> Response -> Response
setBodyRaw :: Body -> Response -> Response
setBodyRaw Body
bodyRaw = ResponseBody -> Response -> Response
setBody (Body -> ResponseBody
ResponseBodyRaw Body
bodyRaw)

setBodyFile :: FilePath -> Response -> Response
setBodyFile :: String -> Response -> Response
setBodyFile String
path = ResponseBody -> Response -> Response
setBody (String -> ResponseBody
ResponseBodyFile String
path) -- TODO: setHeader???

setBodyEventSource :: EventSource -> Response -> Response
setBodyEventSource :: EventSource -> Response -> Response
setBodyEventSource EventSource
source Response
response =
  Response
response
    Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
Function.& ResponseBody -> Response -> Response
setBody (EventSource -> ResponseBody
ResponseBodyEventSource EventSource
source)

setPlaintext :: Text.Text -> Response -> Response
setPlaintext :: Text -> Response -> Response
setPlaintext Text
text Response
response =
  Response
response
    Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
Function.& (HeaderName, ByteString) -> Response -> Response
setHeader (HeaderName
"Content-Type", ByteString
"text/plain")
    Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
Function.& Body -> Response -> Response
setBodyRaw (ByteString -> Body
LBS.fromStrict (ByteString -> Body) -> (Text -> ByteString) -> Text -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> Body) -> Text -> Body
forall a b. (a -> b) -> a -> b
$ Text
text)

setHTML :: LBS.ByteString -> Response -> Response
setHTML :: Body -> Response -> Response
setHTML Body
htmlRaw Response
response =
  Response
response
    Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
Function.& ResponseBody -> Response -> Response
setBody (Body -> ResponseBody
ResponseBodyRaw Body
htmlRaw)
    Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
Function.& (HeaderName, ByteString) -> Response -> Response
setHeader (HeaderName
"Content-Type", ByteString
"text/html")

setJSON :: Aeson.ToJSON a => a -> Response -> Response
setJSON :: a -> Response -> Response
setJSON a
value Response
response =
  Response
response
    Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
Function.& (HeaderName, ByteString) -> Response -> Response
setHeader (HeaderName
"Content-Type", ByteString
"application/json")
    Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
Function.& Body -> Response -> Response
setBodyRaw (a -> Body
forall a. ToJSON a => a -> Body
Aeson.encode a
value)

static :: MonadOkapi m => Handler m
static :: Handler m
static = do
  Text
filePathText <- Text -> Path -> Text
Text.intercalate Text
"/" (Path -> Text) -> m Path -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Path
forall (m :: * -> *). MonadOkapi m => m Path
path
  let filePath :: String
filePath = Text -> String
Text.unpack Text
filePathText
  Response
ok Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
Function.& String -> Response -> Response
setBodyFile String
filePath Response -> (Response -> Handler m) -> Handler m
forall a b. a -> (a -> b) -> b
Function.& Response -> Handler m
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- $serverSentEvents

data Event
  = Event
      { Event -> Maybe Text
eventName :: Maybe Text.Text,
        Event -> Maybe Text
eventID :: Maybe Text.Text,
        Event -> Body
eventData :: LBS.ByteString
      }
  | CommentEvent LBS.ByteString
  | CloseEvent
  deriving (Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show, Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq)

class ToSSE a where
  toSSE :: a -> Event

type Chan a = (Unagi.InChan a, Unagi.OutChan a)

type EventSource = Chan Event

newEventSource :: IO EventSource
newEventSource :: IO EventSource
newEventSource = IO EventSource
forall a. IO (InChan a, OutChan a)
Unagi.newChan

sendValue :: ToSSE a => EventSource -> a -> IO ()
sendValue :: EventSource -> a -> IO ()
sendValue (InChan Event
inChan, OutChan Event
_outChan) = InChan Event -> Event -> IO ()
forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan Event
inChan (Event -> IO ()) -> (a -> Event) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Event
forall a. ToSSE a => a -> Event
toSSE

sendEvent :: EventSource -> Event -> IO ()
sendEvent :: EventSource -> Event -> IO ()
sendEvent (InChan Event
inChan, OutChan Event
_outChan) = InChan Event -> Event -> IO ()
forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan Event
inChan

-- BELOW IS INTERNAL

eventSourceAppUnagiChan :: EventSource -> WAI.Application
eventSourceAppUnagiChan :: EventSource -> Application
eventSourceAppUnagiChan (InChan Event
inChan, OutChan Event
_outChan) Request
req Response -> IO ResponseReceived
sendResponse = do
  OutChan Event
outChan <- IO (OutChan Event) -> IO (OutChan Event)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO (OutChan Event) -> IO (OutChan Event))
-> IO (OutChan Event) -> IO (OutChan Event)
forall a b. (a -> b) -> a -> b
$ InChan Event -> IO (OutChan Event)
forall a. InChan a -> IO (OutChan a)
Unagi.dupChan InChan Event
inChan
  IO ServerEvent -> Application
eventSourceAppIO (Event -> ServerEvent
eventToServerEvent (Event -> ServerEvent) -> IO Event -> IO ServerEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OutChan Event -> IO Event
forall a. OutChan a -> IO a
Unagi.readChan OutChan Event
outChan) Request
req Response -> IO ResponseReceived
sendResponse

eventSourceAppIO :: IO WAI.ServerEvent -> WAI.Application
eventSourceAppIO :: IO ServerEvent -> Application
eventSourceAppIO IO ServerEvent
src Request
_ Response -> IO ResponseReceived
sendResponse =
  Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
    Status -> Headers -> StreamingBody -> Response
WAI.responseStream
      Status
HTTP.status200
      [(HeaderName
HTTP.hContentType, ByteString
"text/event-stream")]
      (StreamingBody -> Response) -> StreamingBody -> Response
forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk IO ()
flush -> do
        IO ()
flush
        (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
Function.fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
          ServerEvent
se <- IO ServerEvent
src
          case ServerEvent -> Maybe Builder
eventToBuilder ServerEvent
se of
            Maybe Builder
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just Builder
b -> Builder -> IO ()
sendChunk Builder
b IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
flush IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop

eventToBuilder :: WAI.ServerEvent -> Maybe Builder.Builder
eventToBuilder :: ServerEvent -> Maybe Builder
eventToBuilder (WAI.CommentEvent Builder
txt) = Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Builder -> Builder -> Builder
field Builder
commentField Builder
txt
eventToBuilder (WAI.RetryEvent Int
n) = Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Builder -> Builder -> Builder
field Builder
retryField (String -> Builder
Builder.string8 (String -> Builder) -> (Int -> String) -> Int -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Builder) -> Int -> Builder
forall a b. (a -> b) -> a -> b
$ Int
n)
eventToBuilder ServerEvent
WAI.CloseEvent = Maybe Builder
forall a. Maybe a
Nothing
eventToBuilder (WAI.ServerEvent Maybe Builder
n Maybe Builder
i [Builder]
d) =
  Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$
    Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (Maybe Builder -> Builder -> Builder
name Maybe Builder
n (Maybe Builder -> Builder -> Builder
evid Maybe Builder
i (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> Builder -> Builder
evdata ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
d) Builder
nl)) Builder
nl
  where
    name :: Maybe Builder -> Builder -> Builder
name Maybe Builder
Nothing = Builder -> Builder
forall a. a -> a
id
    name (Just Builder
n') = Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (Builder -> Builder -> Builder
field Builder
nameField Builder
n')
    evid :: Maybe Builder -> Builder -> Builder
evid Maybe Builder
Nothing = Builder -> Builder
forall a. a -> a
id
    evid (Just Builder
i') = Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (Builder -> Builder -> Builder
field Builder
idField Builder
i')
    evdata :: Builder -> Builder -> Builder
evdata Builder
d' = Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (Builder -> Builder -> Builder
field Builder
dataField Builder
d')

nl :: Builder.Builder
nl :: Builder
nl = Char -> Builder
Builder.char7 Char
'\n'

nameField, idField, dataField, retryField, commentField :: Builder.Builder
nameField :: Builder
nameField = String -> Builder
Builder.string7 String
"event:"
idField :: Builder
idField = String -> Builder
Builder.string7 String
"id:"
dataField :: Builder
dataField = String -> Builder
Builder.string7 String
"data:"
retryField :: Builder
retryField = String -> Builder
Builder.string7 String
"retry:"
commentField :: Builder
commentField = Char -> Builder
Builder.char7 Char
':'

-- | Wraps the text as a labeled field of an event stream.
field :: Builder.Builder -> Builder.Builder -> Builder.Builder
field :: Builder -> Builder -> Builder
field Builder
l Builder
b = Builder
l Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
b Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
nl

eventToServerEvent :: Event -> WAI.ServerEvent
eventToServerEvent :: Event -> ServerEvent
eventToServerEvent Event {Maybe Text
Body
eventData :: Body
eventID :: Maybe Text
eventName :: Maybe Text
eventData :: Event -> Body
eventID :: Event -> Maybe Text
eventName :: Event -> Maybe Text
..} =
  Maybe Builder -> Maybe Builder -> [Builder] -> ServerEvent
WAI.ServerEvent
    (ByteString -> Builder
Builder.byteString (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> Builder) -> Maybe Text -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
eventName)
    (ByteString -> Builder
Builder.byteString (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> Builder) -> Maybe Text -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
eventID)
    (Word8 -> Builder
Builder.word8 (Word8 -> Builder) -> [Word8] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Body -> [Word8]
LBS.unpack Body
eventData)
eventToServerEvent (CommentEvent Body
comment) = Builder -> ServerEvent
WAI.CommentEvent (Builder -> ServerEvent) -> Builder -> ServerEvent
forall a b. (a -> b) -> a -> b
$ Body -> Builder
Builder.lazyByteString Body
comment
eventToServerEvent Event
CloseEvent = ServerEvent
WAI.CloseEvent

-- $wai
--
-- These functions are for interfacing with WAI (Web Application Interface).

run :: Monad m => (forall a. m a -> IO a) -> OkapiT m Response -> IO ()
run :: (forall a. m a -> IO a) -> OkapiT m Response -> IO ()
run = Int
-> Response
-> (forall a. m a -> IO a)
-> OkapiT m Response
-> IO ()
forall (m :: * -> *).
Monad m =>
Int
-> Response
-> (forall a. m a -> IO a)
-> OkapiT m Response
-> IO ()
serve Int
3000 Response
notFound

serve ::
  Monad m =>
  -- | Port
  Int ->
  -- | Default Response
  Response ->
  -- | Monad unlift function
  (forall a. m a -> IO a) ->
  -- | Parser
  OkapiT m Response ->
  IO ()
serve :: Int
-> Response
-> (forall a. m a -> IO a)
-> OkapiT m Response
-> IO ()
serve Int
port Response
defaultResponse forall a. m a -> IO a
hoister OkapiT m Response
okapiT = Int -> Application -> IO ()
WAI.run Int
port (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ Response
-> (forall a. m a -> IO a) -> OkapiT m Response -> Application
forall (m :: * -> *).
Monad m =>
Response
-> (forall a. m a -> IO a) -> OkapiT m Response -> Application
app Response
defaultResponse forall a. m a -> IO a
hoister OkapiT m Response
okapiT

serveTLS ::
  Monad m =>
  WAI.TLSSettings ->
  WAI.Settings ->
  Response ->
  (forall a. m a -> IO a) ->
  OkapiT m Response ->
  IO ()
serveTLS :: TLSSettings
-> Settings
-> Response
-> (forall a. m a -> IO a)
-> OkapiT m Response
-> IO ()
serveTLS TLSSettings
tlsSettings Settings
settings Response
defaultResponse forall a. m a -> IO a
hoister OkapiT m Response
okapiT = TLSSettings -> Settings -> Application -> IO ()
WAI.runTLS TLSSettings
tlsSettings Settings
settings (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ Response
-> (forall a. m a -> IO a) -> OkapiT m Response -> Application
forall (m :: * -> *).
Monad m =>
Response
-> (forall a. m a -> IO a) -> OkapiT m Response -> Application
app Response
defaultResponse forall a. m a -> IO a
hoister OkapiT m Response
okapiT

serveWebsockets ::
  Monad m =>
  WebSockets.ConnectionOptions ->
  WebSockets.ServerApp ->
  Int ->
  Response ->
  (forall a. m a -> IO a) ->
  OkapiT m Response ->
  IO ()
serveWebsockets :: ConnectionOptions
-> ServerApp
-> Int
-> Response
-> (forall a. m a -> IO a)
-> OkapiT m Response
-> IO ()
serveWebsockets ConnectionOptions
connSettings ServerApp
serverApp Int
port Response
defaultResponse forall a. m a -> IO a
hoister OkapiT m Response
okapiT = Int -> Application -> IO ()
WAI.run Int
port (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ ConnectionOptions
-> ServerApp
-> Response
-> (forall a. m a -> IO a)
-> OkapiT m Response
-> Application
forall (m :: * -> *).
Monad m =>
ConnectionOptions
-> ServerApp
-> Response
-> (forall a. m a -> IO a)
-> OkapiT m Response
-> Application
websocketsApp ConnectionOptions
connSettings ServerApp
serverApp Response
defaultResponse forall a. m a -> IO a
hoister OkapiT m Response
okapiT

serveWebsocketsTLS ::
  Monad m =>
  WAI.TLSSettings ->
  WAI.Settings ->
  WebSockets.ConnectionOptions ->
  WebSockets.ServerApp ->
  Response ->
  (forall a. m a -> IO a) ->
  OkapiT m Response ->
  IO ()
serveWebsocketsTLS :: TLSSettings
-> Settings
-> ConnectionOptions
-> ServerApp
-> Response
-> (forall a. m a -> IO a)
-> OkapiT m Response
-> IO ()
serveWebsocketsTLS TLSSettings
tlsSettings Settings
settings ConnectionOptions
connSettings ServerApp
serverApp Response
defaultResponse forall a. m a -> IO a
hoister OkapiT m Response
okapiT = TLSSettings -> Settings -> Application -> IO ()
WAI.runTLS TLSSettings
tlsSettings Settings
settings (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ ConnectionOptions
-> ServerApp
-> Response
-> (forall a. m a -> IO a)
-> OkapiT m Response
-> Application
forall (m :: * -> *).
Monad m =>
ConnectionOptions
-> ServerApp
-> Response
-> (forall a. m a -> IO a)
-> OkapiT m Response
-> Application
websocketsApp ConnectionOptions
connSettings ServerApp
serverApp Response
defaultResponse forall a. m a -> IO a
hoister OkapiT m Response
okapiT

-- | Turns a parser into a WAI application
app ::
  Monad m =>
  -- | The default response to pure if parser fails
  Response ->
  -- | Function for "unlifting" monad inside @OkapiT@ to @IO@ monad
  (forall a. m a -> IO a) ->
  -- | The parser used to equals the request
  OkapiT m Response ->
  WAI.Application
app :: Response
-> (forall a. m a -> IO a) -> OkapiT m Response -> Application
app Response
defaultResponse forall a. m a -> IO a
hoister OkapiT m Response
okapiT Request
waiRequest Response -> IO ResponseReceived
respond = do
  State
state <- Request -> IO State
waiRequestToState Request
waiRequest
  (Either Failure Response
eitherFailureOrResponse, State
_state) <- (StateT State IO (Either Failure Response)
-> State -> IO (Either Failure Response, State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (StateT State IO (Either Failure Response)
 -> State -> IO (Either Failure Response, State))
-> (OkapiT IO Response
    -> StateT State IO (Either Failure Response))
-> OkapiT IO Response
-> State
-> IO (Either Failure Response, State)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Failure (StateT State IO) Response
-> StateT State IO (Either Failure Response)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT Failure (StateT State IO) Response
 -> StateT State IO (Either Failure Response))
-> (OkapiT IO Response
    -> ExceptT Failure (StateT State IO) Response)
-> OkapiT IO Response
-> StateT State IO (Either Failure Response)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OkapiT IO Response -> ExceptT Failure (StateT State IO) Response
forall (m :: * -> *) a.
OkapiT m a -> ExceptT Failure (StateT State m) a
unOkapiT (OkapiT IO Response
 -> State -> IO (Either Failure Response, State))
-> OkapiT IO Response
-> State
-> IO (Either Failure Response, State)
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> IO a) -> OkapiT m Response -> OkapiT IO Response
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
Morph.hoist forall a. m a -> IO a
hoister OkapiT m Response
okapiT) State
state
  let response :: Response
response =
        case Either Failure Response
eitherFailureOrResponse of
          Left Failure
Skip -> Response
defaultResponse
          Left (Error Response
errorResponse) -> Response
errorResponse
          Right Response
succesfulResponse -> Response
succesfulResponse
  Response -> Application
responseToWaiApp Response
response Request
waiRequest Response -> IO ResponseReceived
respond
  where
    responseToWaiApp :: Response -> WAI.Application
    responseToWaiApp :: Response -> Application
responseToWaiApp (Response {Status
Headers
ResponseBody
responseBody :: ResponseBody
responseHeaders :: Headers
responseStatus :: Status
responseBody :: Response -> ResponseBody
responseHeaders :: Response -> Headers
responseStatus :: Response -> Status
..}) Request
waiRequest Response -> IO ResponseReceived
respond = case ResponseBody
responseBody of
      ResponseBodyRaw Body
body -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> Headers -> Body -> Response
WAI.responseLBS (Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status) -> Int -> Status
forall a b. (a -> b) -> a -> b
$ Status -> Int
forall a. Enum a => a -> Int
fromEnum Status
responseStatus) Headers
responseHeaders Body
body
      ResponseBodyFile String
filePath -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> Headers -> String -> Maybe FilePart -> Response
WAI.responseFile (Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status) -> Int -> Status
forall a b. (a -> b) -> a -> b
$ Status -> Int
forall a. Enum a => a -> Int
fromEnum Status
responseStatus) Headers
responseHeaders String
filePath Maybe FilePart
forall a. Maybe a
Nothing
      ResponseBodyEventSource EventSource
eventSource -> (GzipSettings -> Middleware
WAI.gzip GzipSettings
forall a. Default a => a
WAI.def Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ EventSource -> Application
eventSourceAppUnagiChan EventSource
eventSource) Request
waiRequest Response -> IO ResponseReceived
respond

    waiRequestToState :: WAI.Request -> IO State
    waiRequestToState :: Request -> IO State
waiRequestToState Request
waiRequest = do
      Body
requestBody <- Request -> IO Body
WAI.strictRequestBody Request
waiRequest -- TODO: Use lazy request body???
      let requestMethod :: Method
requestMethod = ByteString -> Method
forall a. a -> Maybe a
Just (ByteString -> Method) -> ByteString -> Method
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
WAI.requestMethod Request
waiRequest
          requestPath :: Path
requestPath = Request -> Path
WAI.pathInfo Request
waiRequest
          requestQuery :: Query
requestQuery = ((Text, Maybe Text) -> (Text, QueryValue))
-> [(Text, Maybe Text)] -> Query
forall a b. (a -> b) -> [a] -> [b]
map (\case (Text
name, Maybe Text
Nothing) -> (Text
name, QueryValue
QueryFlag); (Text
name, Just Text
txt) -> (Text
name, Text -> QueryValue
QueryParam Text
txt)) ([(Text, Maybe Text)] -> Query) -> [(Text, Maybe Text)] -> Query
forall a b. (a -> b) -> a -> b
$ Query -> [(Text, Maybe Text)]
HTTP.queryToQueryText (Query -> [(Text, Maybe Text)]) -> Query -> [(Text, Maybe Text)]
forall a b. (a -> b) -> a -> b
$ Request -> Query
WAI.queryString Request
waiRequest
          requestHeaders :: Headers
requestHeaders = Request -> Headers
WAI.requestHeaders Request
waiRequest
          stateRequest :: Request
stateRequest = Request :: Method -> Path -> Query -> Body -> Headers -> Request
Request {Query
Headers
Path
Method
Body
requestHeaders :: Headers
requestQuery :: Query
requestPath :: Path
requestMethod :: Method
requestBody :: Body
requestHeaders :: Headers
requestBody :: Body
requestQuery :: Query
requestPath :: Path
requestMethod :: Method
..}
          stateVault :: Vault
stateVault = Request -> Vault
WAI.vault Request
waiRequest

      State -> IO State
forall (f :: * -> *) a. Applicative f => a -> f a
pure State :: Request -> Vault -> State
State {Vault
Request
stateVault :: Vault
stateRequest :: Request
stateVault :: Vault
stateRequest :: Request
..}

-- | Turns a parsers into a WAI application with WebSocket functionality
-- See __ for information on how to create a WebSocket server
websocketsApp ::
  Monad m =>
  -- | Connection options configuration for the WebSocket server
  WebSockets.ConnectionOptions ->
  -- | The server to use for handling WebSocket connections
  WebSockets.ServerApp ->
  Response ->
  (forall a. m a -> IO a) ->
  OkapiT m Response ->
  WAI.Application
websocketsApp :: ConnectionOptions
-> ServerApp
-> Response
-> (forall a. m a -> IO a)
-> OkapiT m Response
-> Application
websocketsApp ConnectionOptions
connSettings ServerApp
serverApp Response
defaultResponse forall a. m a -> IO a
hoister OkapiT m Response
okapiT =
  let backupApp :: Application
backupApp = Response
-> (forall a. m a -> IO a) -> OkapiT m Response -> Application
forall (m :: * -> *).
Monad m =>
Response
-> (forall a. m a -> IO a) -> OkapiT m Response -> Application
app Response
defaultResponse forall a. m a -> IO a
hoister OkapiT m Response
okapiT
   in ConnectionOptions -> ServerApp -> Middleware
WebSockets.websocketsOr ConnectionOptions
connSettings ServerApp
serverApp Application
backupApp

-- $middleware
--
-- Middlewares allow you to modify the behavior of Okapi handlers.
-- Middlewares are functions that take a handler and return another handler.
-- Middlewares can be composed with the fish operator @>=>@.
--
-- @
--  clearHeadersMiddleware >=> pathPrefix ["jello"] :: forall m. Middleware m
-- @

-- | A middleware takes an action that returns a @Response@ and can modify the action in various ways
type Middleware m = Handler m -> Handler m

applyMiddlewares :: MonadOkapi m => [Middleware m] -> Middleware m
applyMiddlewares :: [Middleware m] -> Middleware m
applyMiddlewares [Middleware m]
middlewares Handler m
handler =
  (Handler m -> Middleware m -> Handler m)
-> Handler m -> [Middleware m] -> Handler m
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl (\Handler m
handler Middleware m
middleware -> Middleware m
middleware Handler m
handler) Handler m
handler [Middleware m]
middlewares

-- TODO: Is this needed? Idea taken from OCaml Dream framework

scope :: MonadOkapi m => Path -> [Middleware m] -> Middleware m
scope :: Path -> [Middleware m] -> Middleware m
scope Path
prefix [Middleware m]
middlewares Handler m
handler = m Path
forall (m :: * -> *). MonadOkapi m => m Path
path m Path -> Path -> m ()
forall a (m :: * -> *). (Eq a, MonadOkapi m) => m a -> a -> m ()
`is` Path
prefix m () -> Middleware m
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Middleware m] -> Middleware m
forall (m :: * -> *).
MonadOkapi m =>
[Middleware m] -> Middleware m
applyMiddlewares [Middleware m]
middlewares Handler m
handler

clearHeadersMiddleware :: MonadOkapi m => Middleware m
clearHeadersMiddleware :: Middleware m
clearHeadersMiddleware Handler m
handler = Headers -> Response -> Response
setHeaders [] (Response -> Response) -> Middleware m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler m
handler

prefixPathMiddleware :: MonadOkapi m => Path -> Middleware m
prefixPathMiddleware :: Path -> Middleware m
prefixPathMiddleware Path
prefix Handler m
handler = m Path
forall (m :: * -> *). MonadOkapi m => m Path
path m Path -> Path -> m ()
forall a (m :: * -> *). (Eq a, MonadOkapi m) => m a -> a -> m ()
`is` Path
prefix m () -> Middleware m
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handler m
handler

-- $routing
--
-- Okapi implements routes and type-safe relative URLs using bidirectional pattern synonyms and view patterns.
-- Routing can be extended to dispatch on any property of the request, including method, path, query, headers, and even body.
-- By default, Okapi provides a @route@ function for dispatching on the path of the request.

type Router m a =
  -- | Parser for dispatcher
  m a ->
  -- | Dispatches parser result to the correct handler
  (a -> Handler m) ->
  Handler m

route :: MonadOkapi m => Router m a
route :: Router m a
route m a
parser a -> Handler m
dispatcher = m a
parser Router m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Handler m
dispatcher

-- $patterns

pattern PathParam :: (Web.ToHttpApiData a, Web.FromHttpApiData a) => a -> Text.Text
pattern $bPathParam :: a -> Text
$mPathParam :: forall r a.
(ToHttpApiData a, FromHttpApiData a) =>
Text -> (a -> r) -> (Void# -> r) -> r
PathParam param <-
  (Web.parseUrlPiece -> Right param)
  where
    PathParam a
param = a -> Text
forall a. ToHttpApiData a => a -> Text
Web.toUrlPiece a
param

pattern IsQueryParam :: (Web.ToHttpApiData a, Web.FromHttpApiData a) => a -> QueryValue
pattern $bIsQueryParam :: a -> QueryValue
$mIsQueryParam :: forall r a.
(ToHttpApiData a, FromHttpApiData a) =>
QueryValue -> (a -> r) -> (Void# -> r) -> r
IsQueryParam param <-
  QueryParam (Web.parseUrlPiece -> Right param)
  where
    IsQueryParam a
param = Text -> QueryValue
QueryParam (Text -> QueryValue) -> Text -> QueryValue
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. ToHttpApiData a => a -> Text
Web.toUrlPiece a
param

pattern GET :: Method
pattern $bGET :: Method
$mGET :: forall r. Method -> (Void# -> r) -> (Void# -> r) -> r
GET = Just "GET"

pattern POST :: Method
pattern $bPOST :: Method
$mPOST :: forall r. Method -> (Void# -> r) -> (Void# -> r) -> r
POST = Just "POST"

pattern PATCH :: Method
pattern $bPATCH :: Method
$mPATCH :: forall r. Method -> (Void# -> r) -> (Void# -> r) -> r
PATCH = Just "PATCH"

pattern DELETE :: Method
pattern $bDELETE :: Method
$mDELETE :: forall r. Method -> (Void# -> r) -> (Void# -> r) -> r
DELETE = Just "DELETE"

pattern PUT :: Method
pattern $bPUT :: Method
$mPUT :: forall r. Method -> (Void# -> r) -> (Void# -> r) -> r
PUT = Just "PUT"

-- pattern IsQueryParam :: Web.FromHttpApiData a => a -> Maybe QueryValue
-- pattern IsQueryParam value <- Just (QueryParam (Web.parseQueryParam -> Right value))

pattern HasQueryFlag :: Maybe QueryValue
pattern $mHasQueryFlag :: forall r. Maybe QueryValue -> (Void# -> r) -> (Void# -> r) -> r
HasQueryFlag <- Just QueryFlag

viewQuery :: Text.Text -> Query -> (Maybe QueryValue, Query)
viewQuery :: Text -> Query -> (Maybe QueryValue, Query)
viewQuery Text
name Query
query = case Text -> Query -> Maybe QueryValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Text
name Query
query of
  Maybe QueryValue
Nothing -> (Maybe QueryValue
forall a. Maybe a
Nothing, Query
query)
  Just QueryValue
value -> (QueryValue -> Maybe QueryValue
forall a. a -> Maybe a
Just QueryValue
value, (Text, QueryValue) -> Query -> Query
forall a. Eq a => a -> [a] -> [a]
List.delete (Text
name, QueryValue
value) Query
query)

viewQueryParam :: Web.FromHttpApiData a => Text.Text -> Query -> (Maybe a, Query)
viewQueryParam :: Text -> Query -> (Maybe a, Query)
viewQueryParam Text
name Query
query = case Text -> Query -> Maybe QueryValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Text
name Query
query of
  Just (QueryParam Text
param) -> case Text -> Maybe a
forall a. FromHttpApiData a => Text -> Maybe a
Web.parseQueryParamMaybe Text
param of
    Maybe a
Nothing -> (Maybe a
forall a. Maybe a
Nothing, Query
query)
    Just a
value -> (a -> Maybe a
forall a. a -> Maybe a
Just a
value, (Text, QueryValue) -> Query -> Query
forall a. Eq a => a -> [a] -> [a]
List.delete (Text
name, Text -> QueryValue
QueryParam Text
param) Query
query)
  Maybe QueryValue
_ -> (Maybe a
forall a. Maybe a
Nothing, Query
query)

-- $relativeURLs
--
-- Relative URLs are useful when we want to refer to other locations within our app.
-- Thanks to bidirectional patterns, we can use the same pattern to deconstruct an incoming request
-- AND construct the relative URL that leads to itself.

data RelURL = RelURL Path Query

-- TODO: Use ToURL typeclass for Path and Query, then combine for RelURL??
renderRelURL :: RelURL -> Text.Text
renderRelURL :: RelURL -> Text
renderRelURL (RelURL Path
path Query
query) = case (Path
path, Query
query) of
  ([], []) -> Text
""
  ([], Query
q) -> Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Query -> Text
renderQuery Query
q
  (Path
p, []) -> Path -> Text
renderPath Path
p
  (Path
p, Query
q) -> Path -> Text
renderPath Path
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Query -> Text
renderQuery Query
q

renderPath :: Path -> Text.Text
renderPath :: Path -> Text
renderPath [] = Text
"/"
renderPath (Text
pathSeg : Path
path) = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pathSeg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Path -> Text
loop Path
path
  where
    loop :: Path -> Text.Text
    loop :: Path -> Text
loop [] = Text
""
    loop (Text
pathSeg : Path
path) = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pathSeg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Path -> Text
loop Path
path

renderQuery :: Query -> Text.Text
renderQuery :: Query -> Text
renderQuery [] = Text
""
renderQuery ((Text
name, QueryValue
QueryFlag) : Query
query) = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"&" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Query -> Text
renderQuery Query
query
renderQuery ((Text
name, QueryParam Text
value) : Query
query) = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"&" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Query -> Text
renderQuery Query
query

parseRelURL :: Text.Text -> Maybe RelURL
parseRelURL :: Text -> Maybe RelURL
parseRelURL Text
possibleRelURL = Either String RelURL -> Maybe RelURL
forall l r. Either l r -> Maybe r
Either.eitherToMaybe (Either String RelURL -> Maybe RelURL)
-> Either String RelURL -> Maybe RelURL
forall a b. (a -> b) -> a -> b
$
  (Parser RelURL -> Text -> Either String RelURL)
-> Text -> Parser RelURL -> Either String RelURL
forall a b c. (a -> b -> c) -> b -> a -> c
flip Parser RelURL -> Text -> Either String RelURL
forall a. Parser a -> Text -> Either String a
Atto.parseOnly Text
possibleRelURL (Parser RelURL -> Either String RelURL)
-> Parser RelURL -> Either String RelURL
forall a b. (a -> b) -> a -> b
$ do
    Path
path <- Parser Text Text -> Parser Text Path
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Combinators.many Parser Text Text
pathSeg
    Maybe Char
maybeQueryStart <- Parser Text Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Combinators.optional (Parser Text Char -> Parser Text (Maybe Char))
-> Parser Text Char -> Parser Text (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
Atto.char Char
'?'
    case Maybe Char
maybeQueryStart of
      Maybe Char
Nothing -> RelURL -> Parser RelURL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelURL -> Parser RelURL) -> RelURL -> Parser RelURL
forall a b. (a -> b) -> a -> b
$ Path -> Query -> RelURL
RelURL Path
path []
      Just Char
_ -> do
        Query
query <- Parser Text (Text, QueryValue) -> Parser Text Query
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Combinators.many Parser Text (Text, QueryValue)
queryParam
        RelURL -> Parser RelURL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelURL -> Parser RelURL) -> RelURL -> Parser RelURL
forall a b. (a -> b) -> a -> b
$ Path -> Query -> RelURL
RelURL Path
path Query
query
  where
    pathSeg :: Atto.Parser Text.Text
    pathSeg :: Parser Text Text
pathSeg = do
      Char -> Parser Text Char
Atto.char Char
'/'
      (Char -> Bool) -> Parser Text Text
Atto.takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'?')

    queryParam :: Atto.Parser (Text.Text, QueryValue)
    queryParam :: Parser Text (Text, QueryValue)
queryParam = do
      Text
queryParamName <- (Char -> Bool) -> Parser Text Text
Atto.takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'&')
      Maybe Char
mbEquals <- Parser Text Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Combinators.optional (Parser Text Char -> Parser Text (Maybe Char))
-> Parser Text Char -> Parser Text (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
Atto.char Char
'='
      case Maybe Char
mbEquals of
        Maybe Char
Nothing -> (Text, QueryValue) -> Parser Text (Text, QueryValue)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
queryParamName, QueryValue
QueryFlag)
        Just Char
_ -> do
          Text
queryParamValue <- (Char -> Bool) -> Parser Text Text
Atto.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'&')
          (Text, QueryValue) -> Parser Text (Text, QueryValue)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
queryParamName, Text -> QueryValue
QueryParam Text
queryParamValue)

-- $testing
--
-- There are two ways to test in Okapi.

testParser ::
  Monad m =>
  OkapiT m Response ->
  Request ->
  m (Either Failure Response, State)
testParser :: OkapiT m Response -> Request -> m (Either Failure Response, State)
testParser OkapiT m Response
okapiT Request
request =
  (StateT State m (Either Failure Response)
-> State -> m (Either Failure Response, State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT (StateT State m (Either Failure Response)
 -> State -> m (Either Failure Response, State))
-> (OkapiT m Response -> StateT State m (Either Failure Response))
-> OkapiT m Response
-> State
-> m (Either Failure Response, State)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Failure (StateT State m) Response
-> StateT State m (Either Failure Response)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT Failure (StateT State m) Response
 -> StateT State m (Either Failure Response))
-> (OkapiT m Response -> ExceptT Failure (StateT State m) Response)
-> OkapiT m Response
-> StateT State m (Either Failure Response)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OkapiT m Response -> ExceptT Failure (StateT State m) Response
forall (m :: * -> *) a.
OkapiT m a -> ExceptT Failure (StateT State m) a
unOkapiT (OkapiT m Response -> State -> m (Either Failure Response, State))
-> OkapiT m Response -> State -> m (Either Failure Response, State)
forall a b. (a -> b) -> a -> b
$ OkapiT m Response
okapiT)
    (Request -> State
requestToState Request
request)
  where
    requestToState :: Request -> State
    requestToState :: Request -> State
requestToState Request
stateRequest = let stateVault :: Vault
stateVault = Vault
forall a. Monoid a => a
mempty in State :: Request -> Vault -> State
State {Vault
Request
stateVault :: Vault
stateRequest :: Request
stateVault :: Vault
stateRequest :: Request
..}

testParserPure ::
  OkapiT Identity.Identity Response ->
  Request ->
  Identity.Identity (Either Failure Response, State)
testParserPure :: OkapiT Identity Response
-> Request -> Identity (Either Failure Response, State)
testParserPure = OkapiT Identity Response
-> Request -> Identity (Either Failure Response, State)
forall (m :: * -> *).
Monad m =>
OkapiT m Response -> Request -> m (Either Failure Response, State)
testParser

testParserIO ::
  OkapiT IO Response ->
  Request ->
  IO (Either Failure Response, State)
testParserIO :: OkapiT IO Response
-> Request -> IO (Either Failure Response, State)
testParserIO = OkapiT IO Response
-> Request -> IO (Either Failure Response, State)
forall (m :: * -> *).
Monad m =>
OkapiT m Response -> Request -> m (Either Failure Response, State)
testParser

-- TODO: Add common assertion helpers. Use Predicate for Contravariant interface??

assert ::
  ((Either Failure Response, State) -> Bool) ->
  (Either Failure Response, State) ->
  Bool
assert :: ((Either Failure Response, State) -> Bool)
-> (Either Failure Response, State) -> Bool
assert (Either Failure Response, State) -> Bool
assertion = (Either Failure Response, State) -> Bool
assertion

assert200 :: (Either Failure Response, State) -> Bool
assert200 :: (Either Failure Response, State) -> Bool
assert200 = \case
  (Right (Response Status
200 Headers
_ ResponseBody
_), State
_) -> Bool
True
  (Either Failure Response, State)
_ -> Bool
False

assert404 :: (Either Failure Response, State) -> Bool
assert404 :: (Either Failure Response, State) -> Bool
assert404 = \case
  (Right (Response Status
404 Headers
_ ResponseBody
_), State
_) -> Bool
True
  (Either Failure Response, State)
_ -> Bool
False

assert500 :: (Either Failure Response, State) -> Bool
assert500 :: (Either Failure Response, State) -> Bool
assert500 = \case
  (Right (Response Status
500 Headers
_ ResponseBody
_), State
_) -> Bool
True
  (Either Failure Response, State)
_ -> Bool
False

testRunSession ::
  Monad m =>
  WAI.Session a ->
  (forall a. m a -> IO a) ->
  OkapiT m Response ->
  IO a
testRunSession :: Session a -> (forall a. m a -> IO a) -> OkapiT m Response -> IO a
testRunSession Session a
session forall a. m a -> IO a
hoister OkapiT m Response
okapiT = do
  let waiApp :: Application
waiApp = Response
-> (forall a. m a -> IO a) -> OkapiT m Response -> Application
forall (m :: * -> *).
Monad m =>
Response
-> (forall a. m a -> IO a) -> OkapiT m Response -> Application
app Response
notFound forall a. m a -> IO a
hoister OkapiT m Response
okapiT
  Session a -> Application -> IO a
forall a. Session a -> Application -> IO a
WAI.runSession Session a
session Application
waiApp

testWithSession ::
  Monad m =>
  (forall a. m a -> IO a) ->
  OkapiT m Response ->
  WAI.Session a ->
  IO a
testWithSession :: (forall a. m a -> IO a) -> OkapiT m Response -> Session a -> IO a
testWithSession forall a. m a -> IO a
hoister OkapiT m Response
okapiT Session a
session = Session a -> (forall a. m a -> IO a) -> OkapiT m Response -> IO a
forall (m :: * -> *) a.
Monad m =>
Session a -> (forall a. m a -> IO a) -> OkapiT m Response -> IO a
testRunSession Session a
session forall a. m a -> IO a
hoister OkapiT m Response
okapiT

testRequest :: Request -> WAI.Session WAI.SResponse
testRequest :: Request -> Session SResponse
testRequest = SRequest -> Session SResponse
WAI.srequest (SRequest -> Session SResponse)
-> (Request -> SRequest) -> Request -> Session SResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> SRequest
requestToSRequest
  where
    requestToSRequest :: Request -> WAI.SRequest
    requestToSRequest :: Request -> SRequest
requestToSRequest request :: Request
request@(Request Method
mbMethod Path
path Query
query Body
body Headers
headers) =
      let requestMethod :: ByteString
requestMethod = ByteString -> Method -> ByteString
forall a. a -> Maybe a -> a
Maybe.fromMaybe ByteString
HTTP.methodGet Method
mbMethod
          sRequestBody :: Body
sRequestBody = Body
body
          rawPath :: ByteString
rawPath = Path -> Query -> RelURL
RelURL Path
path Query
query RelURL -> (RelURL -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
Function.& \RelURL
relURL -> Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ RelURL -> Text
renderRelURL RelURL
relURL
          sRequestRequest :: Request
sRequestRequest = Request -> ByteString -> Request
WAI.setPath (Request
WAI.defaultRequest {requestMethod :: ByteString
WAI.requestMethod = ByteString
requestMethod, requestHeaders :: Headers
WAI.requestHeaders = Headers
headers}) ByteString
rawPath
       in Request -> Body -> SRequest
WAI.SRequest Request
sRequestRequest Body
sRequestBody

-- $HasSession

type Session = Map.Map BS.ByteString BS.ByteString

class Monad m => HasSession m where
  sessionSecret :: m BS.ByteString
  getSession :: m (Maybe Session)
  putSession :: Session -> m ()

session :: (MonadOkapi m, HasSession m) => m Session
session :: m Session
session = do
  Maybe Session
cachedSession <- m (Maybe Session)
forall (m :: * -> *). HasSession m => m (Maybe Session)
getSession
  m Session -> (Session -> m Session) -> Maybe Session -> m Session
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Session
forall (m :: * -> *). (MonadOkapi m, HasSession m) => m Session
sessionInCookie Session -> m Session
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Session
cachedSession

sessionInCookie :: (MonadOkapi m, HasSession m) => m Session
sessionInCookie :: m Session
sessionInCookie = do
  ByteString
encodedSession <- ByteString -> m ByteString
forall (m :: * -> *). MonadOkapi m => ByteString -> m ByteString
cookieCrumb ByteString
"session"
  ByteString
secret <- m ByteString
forall (m :: * -> *). HasSession m => m ByteString
sessionSecret
  Session -> m Session
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Session -> m Session) -> Session -> m Session
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Session
decodeSession ByteString
secret ByteString
encodedSession

sessionLookup :: HasSession m => MonadOkapi m => BS.ByteString -> m BS.ByteString
sessionLookup :: ByteString -> m ByteString
sessionLookup ByteString
key = do
  Method
mbValue <- ByteString -> Session -> Method
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
key (Session -> Method) -> m Session -> m Method
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Session
forall (m :: * -> *). (MonadOkapi m, HasSession m) => m Session
session
  m ByteString
-> (ByteString -> m ByteString) -> Method -> m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ByteString
forall (m :: * -> *) a. MonadOkapi m => m a
next ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure Method
mbValue

sessionInsert :: HasSession m => MonadOkapi m => BS.ByteString -> BS.ByteString -> m ()
sessionInsert :: ByteString -> ByteString -> m ()
sessionInsert ByteString
key ByteString
value = m Session
forall (m :: * -> *). (MonadOkapi m, HasSession m) => m Session
session m Session -> (Session -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Session
sesh -> Session -> m ()
forall (m :: * -> *). HasSession m => Session -> m ()
putSession (ByteString -> ByteString -> Session -> Session
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ByteString
key ByteString
value Session
sesh)

sessionDelete :: HasSession m => MonadOkapi m => BS.ByteString -> m ()
sessionDelete :: ByteString -> m ()
sessionDelete ByteString
key = m Session
forall (m :: * -> *). (MonadOkapi m, HasSession m) => m Session
session m Session -> (Session -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Session
sesh -> Session -> m ()
forall (m :: * -> *). HasSession m => Session -> m ()
putSession (ByteString -> Session -> Session
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ByteString
key Session
sesh)

sessionClear :: HasSession m => m ()
sessionClear :: m ()
sessionClear = Session -> m ()
forall (m :: * -> *). HasSession m => Session -> m ()
putSession Session
forall k a. Map k a
Map.empty

encodeSession :: BS.ByteString -> Session -> BS.ByteString
encodeSession :: ByteString -> Session -> ByteString
encodeSession ByteString
secret Session
session =
  let serial :: ByteString
serial = Bool -> Cookie -> ByteString
HTTP.renderSimpleQuery Bool
False (Cookie -> ByteString) -> Cookie -> ByteString
forall a b. (a -> b) -> a -> b
$ Session -> Cookie
forall k a. Map k a -> [(k, a)]
Map.toList Session
session
      digest :: Digest SHA256
digest = HMAC SHA256 -> Digest SHA256
forall a. HMAC a -> Digest a
HMAC.hmacGetDigest (HMAC SHA256 -> Digest SHA256) -> HMAC SHA256 -> Digest SHA256
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> HMAC SHA256
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
HMAC.hmac ByteString
secret ByteString
serial :: Crypto.Digest Crypto.SHA256
      b64 :: ByteString
b64 = ByteString -> ByteString
BS.encodeBase64' (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
Memory.convert Digest SHA256
digest
   in ByteString
b64 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
serial

decodeSession :: BS.ByteString -> BS.ByteString -> Session
decodeSession :: ByteString -> ByteString -> Session
decodeSession ByteString
secret ByteString
encodedSession =
  let (ByteString
b64, ByteString
serial) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
44 ByteString
encodedSession
      Maybe (Digest SHA256)
mbDigest :: Maybe (Crypto.Digest Crypto.SHA256) = ByteString -> Maybe (Digest SHA256)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
Crypto.digestFromByteString (ByteString -> Maybe (Digest SHA256))
-> ByteString -> Maybe (Digest SHA256)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text ByteString -> ByteString
forall b a. b -> Either a b -> b
Either.fromRight ByteString
BS.empty (Either Text ByteString -> ByteString)
-> Either Text ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text ByteString
BS.decodeBase64 ByteString
b64
   in case Maybe (Digest SHA256)
mbDigest of
        Maybe (Digest SHA256)
Nothing -> Session
forall k a. Map k a
Map.empty
        Just Digest SHA256
digest ->
          if HMAC SHA256 -> Digest SHA256
forall a. HMAC a -> Digest a
HMAC.hmacGetDigest (ByteString -> ByteString -> HMAC SHA256
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
HMAC.hmac ByteString
secret ByteString
serial :: HMAC.HMAC Crypto.SHA256) Digest SHA256 -> Digest SHA256 -> Bool
forall a. Eq a => a -> a -> Bool
== Digest SHA256
digest
            then Cookie -> Session
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Cookie -> Session) -> Cookie -> Session
forall a b. (a -> b) -> a -> b
$ ByteString -> Cookie
HTTP.parseSimpleQuery ByteString
serial
            else Session
forall k a. Map k a
Map.empty

withSession :: (MonadOkapi m, HasSession m) => Middleware m
withSession :: Middleware m
withSession Handler m
handler = do
  Maybe Session
mbSession <- m (Maybe Session)
forall (m :: * -> *). HasSession m => m (Maybe Session)
getSession
  case Maybe Session
mbSession of
    Maybe Session
Nothing -> Handler m
handler
    Just Session
session -> do
      ByteString
secret <- m ByteString
forall (m :: * -> *). HasSession m => m ByteString
sessionSecret
      Response
response <- Handler m
handler
      Response
response
        Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
Function.& (ByteString, ByteString) -> Response -> Response
addSetCookie (ByteString
"session", ByteString -> Session -> ByteString
encodeSession ByteString
secret Session
session)
        Response -> (Response -> Handler m) -> Handler m
forall a b. a -> (a -> b) -> b
Function.& Response -> Handler m
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- $csrfProtection

{-
class Monad m => HasCSRFProtection m where
-}