{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-}

module Okapi.Function
  ( -- FOR RUNNING OKAPI
    runOkapi,
    runOkapiTLS,
    makeOkapiApp,
    -- METHOD PARSERS
    get,
    post,
    head,
    put,
    delete,
    trace,
    connect,
    options,
    patch,
    -- PATH PARSERS
    seg,
    segs,
    segParam,
    segWith,
    path,
    -- QUERY PARAM PARSERS
    queryParam,
    queryFlag,
    -- HEADER PARSERS
    header,
    auth,
    basicAuth,
    -- BODY PARSERS
    bodyJSON,
    bodyForm,
    -- RESPOND FUNCTIONS
    okPlainText,
    okJSON,
    okHTML,
    okLucid,
    connectEventSource,
    noContent,
    file,
    okFile,
    -- FAILURE FUNCTIONS
    skip,
    error,
    error500,
    error401,
    error403,
    error404,
    error422,
    -- ERROR HANDLING
    (<!>),
    optionalError,
    optionError,
  )
where

import qualified Control.Concurrent as Concurrent
import qualified Control.Concurrent.STM.TVar as TVar
import qualified Control.Monad.Except as Except
import qualified Control.Monad.IO.Class as IO
import qualified Control.Monad.Morph as Morph
import qualified Control.Monad.State.Class as State
import qualified Control.Monad.Trans.Except
import qualified Control.Monad.Trans.Except as ExceptT
import qualified Control.Monad.Trans.State.Strict as StateT
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encoding as Aeson
import qualified Data.Bifunctor as Bifunctor
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Data.Foldable as Foldable
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified GHC.Natural as Natural
import qualified Lucid
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WarpTLS as Warp
import qualified Network.Wai.Internal as Wai
import Network.Wai.Middleware.Gzip (gzip, def)
import qualified Okapi.EventSource as EventSource
import Okapi.Type
  ( Failure (Error, Skip),
    Headers,
    MonadOkapi,
    OkapiT (..),
    QueryItem,
    Request (..),
    Response (..),
    File (..),
    Result (..),
    State (..),
  )
import qualified Web.FormUrlEncoded as Web
import qualified Web.HttpApiData as Web
import Prelude hiding (error, head)

-- FOR RUNNING OKAPI

runOkapi :: Monad m => (forall a. m a -> IO a) -> Int -> OkapiT m Result -> IO ()
runOkapi :: (forall a. m a -> IO a) -> Int -> OkapiT m Result -> IO ()
runOkapi forall a. m a -> IO a
hoister Int
port OkapiT m Result
okapiT = do
  String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Running Okapi App on port " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
port
  Int -> Application -> IO ()
Warp.run Int
port (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> IO a) -> OkapiT m Result -> Application
forall (m :: * -> *).
Monad m =>
(forall a. m a -> IO a) -> OkapiT m Result -> Application
makeOkapiApp forall a. m a -> IO a
hoister OkapiT m Result
okapiT

runOkapiTLS :: Monad m => (forall a. m a -> IO a) -> Warp.TLSSettings -> Warp.Settings -> OkapiT m Result -> IO ()
runOkapiTLS :: (forall a. m a -> IO a)
-> TLSSettings -> Settings -> OkapiT m Result -> IO ()
runOkapiTLS forall a. m a -> IO a
hoister TLSSettings
tlsSettings Settings
settings OkapiT m Result
okapiT = do
  String -> IO ()
forall a. Show a => a -> IO ()
print String
"Running servo on port 43"
  TLSSettings -> Settings -> Application -> IO ()
Warp.runTLS TLSSettings
tlsSettings Settings
settings (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> IO a) -> OkapiT m Result -> Application
forall (m :: * -> *).
Monad m =>
(forall a. m a -> IO a) -> OkapiT m Result -> Application
makeOkapiApp forall a. m a -> IO a
hoister OkapiT m Result
okapiT

makeOkapiApp :: Monad m => (forall a. m a -> IO a) -> OkapiT m Result -> Wai.Application
makeOkapiApp :: (forall a. m a -> IO a) -> OkapiT m Result -> Application
makeOkapiApp forall a. m a -> IO a
hoister OkapiT m Result
okapiT Request
waiRequest Response -> IO ResponseReceived
respond = do
  (Either Failure Result
eitherFailureOrResult, State
_state) <- (StateT State IO (Either Failure Result)
-> State -> IO (Either Failure Result, State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
StateT.runStateT (StateT State IO (Either Failure Result)
 -> State -> IO (Either Failure Result, State))
-> (OkapiT IO Result -> StateT State IO (Either Failure Result))
-> OkapiT IO Result
-> State
-> IO (Either Failure Result, State)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Failure (StateT State IO) Result
-> StateT State IO (Either Failure Result)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
ExceptT.runExceptT (ExceptT Failure (StateT State IO) Result
 -> StateT State IO (Either Failure Result))
-> (OkapiT IO Result -> ExceptT Failure (StateT State IO) Result)
-> OkapiT IO Result
-> StateT State IO (Either Failure Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OkapiT IO Result -> ExceptT Failure (StateT State IO) Result
forall (m :: * -> *) a.
OkapiT m a -> ExceptT Failure (StateT State m) a
unOkapiT (OkapiT IO Result -> State -> IO (Either Failure Result, State))
-> OkapiT IO Result -> State -> IO (Either Failure Result, State)
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> IO a) -> OkapiT m Result -> OkapiT IO Result
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 Result
okapiT) (Request -> State
waiRequestToState {-eventSourcePoolTVar-} Request
waiRequest)
  case Either Failure Result
eitherFailureOrResult of
    Left Failure
Skip -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
HTTP.status404 [] ByteString
"Not Found"
    Left (Error Response
response) -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (Response -> Response) -> Response -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Response
responseToWaiResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response
response
    Right (ResultResponse Response
response) -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (Response -> Response) -> Response -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Response
responseToWaiResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response
response
    Right (ResultFile File
file) -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (File -> Response) -> File -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. File -> Response
fileToWaiResponse (File -> IO ResponseReceived) -> File -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ File
file
    Right (ResultEventSource EventSource
eventSource) -> (GzipSettings -> Middleware
gzip GzipSettings
forall a. Default a => a
def Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ EventSource -> Application
EventSource.eventSourceAppUnagiChan EventSource
eventSource) Request
waiRequest Response -> IO ResponseReceived
respond

waiRequestToState :: Wai.Request -> State
waiRequestToState :: Request -> State
waiRequestToState Request
waiRequest =
  let requestMethod :: Method
requestMethod = Request -> Method
Wai.requestMethod Request
waiRequest
      requestPath :: [Text]
requestPath = Request -> [Text]
Wai.pathInfo Request
waiRequest
      requestQuery :: QueryText
requestQuery = Query -> QueryText
HTTP.queryToQueryText (Query -> QueryText) -> Query -> QueryText
forall a b. (a -> b) -> a -> b
$ Request -> Query
Wai.queryString Request
waiRequest
      requestBody :: IO ByteString
requestBody = Request -> IO ByteString
Wai.strictRequestBody Request
waiRequest
      requestHeaders :: ResponseHeaders
requestHeaders = Request -> ResponseHeaders
Wai.requestHeaders Request
waiRequest
      requestVault :: Vault
requestVault = Request -> Vault
Wai.vault Request
waiRequest
      stateRequest :: Request
stateRequest = Request :: Method
-> [Text]
-> QueryText
-> IO ByteString
-> ResponseHeaders
-> Vault
-> Request
Request {QueryText
ResponseHeaders
[Text]
IO ByteString
Method
Vault
requestVault :: Vault
requestHeaders :: ResponseHeaders
requestBody :: IO ByteString
requestQuery :: QueryText
requestPath :: [Text]
requestMethod :: Method
requestVault :: Vault
requestHeaders :: ResponseHeaders
requestBody :: IO ByteString
requestQuery :: QueryText
requestPath :: [Text]
requestMethod :: Method
..}
      stateRequestMethodParsed :: Bool
stateRequestMethodParsed = Bool
False
      stateRequestBodyParsed :: Bool
stateRequestBodyParsed = Bool
False
   in State :: Request -> Bool -> Bool -> State
State {Bool
Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
..}

responseToWaiResponse :: Response -> Wai.Response
responseToWaiResponse :: Response -> Response
responseToWaiResponse Response {Natural
ResponseHeaders
ByteString
responseBody :: Response -> ByteString
responseHeaders :: Response -> ResponseHeaders
responseStatus :: Response -> Natural
responseBody :: ByteString
responseHeaders :: ResponseHeaders
responseStatus :: Natural
..} = Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS (Int -> Status
forall a. Enum a => Int -> a
toEnum (Int -> Status) -> Int -> Status
forall a b. (a -> b) -> a -> b
$ Natural -> Int
forall a. Enum a => a -> Int
fromEnum Natural
responseStatus) ResponseHeaders
responseHeaders ByteString
responseBody

fileToWaiResponse :: File -> Wai.Response
fileToWaiResponse :: File -> Response
fileToWaiResponse File {Natural
String
ResponseHeaders
filePath :: File -> String
fileHeaders :: File -> ResponseHeaders
fileStatus :: File -> Natural
filePath :: String
fileHeaders :: ResponseHeaders
fileStatus :: Natural
..} = Status -> ResponseHeaders -> 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
$ Natural -> Int
forall a. Enum a => a -> Int
fromEnum Natural
fileStatus) ResponseHeaders
fileHeaders String
filePath Maybe FilePart
forall a. Maybe a
Nothing

-- PARSING METHODS

get :: forall m. MonadOkapi m => m ()
get :: m ()
get = Method -> m ()
forall (m :: * -> *). MonadOkapi m => Method -> m ()
method Method
HTTP.methodGet

post :: forall m. MonadOkapi m => m ()
post :: m ()
post = Method -> m ()
forall (m :: * -> *). MonadOkapi m => Method -> m ()
method Method
HTTP.methodPost

head :: forall m. MonadOkapi m => m ()
head :: m ()
head = Method -> m ()
forall (m :: * -> *). MonadOkapi m => Method -> m ()
method Method
HTTP.methodHead

put :: forall m. MonadOkapi m => m ()
put :: m ()
put = Method -> m ()
forall (m :: * -> *). MonadOkapi m => Method -> m ()
method Method
HTTP.methodPut

delete :: forall m. MonadOkapi m => m ()
delete :: m ()
delete = Method -> m ()
forall (m :: * -> *). MonadOkapi m => Method -> m ()
method Method
HTTP.methodDelete

trace :: forall m. MonadOkapi m => m ()
trace :: m ()
trace = Method -> m ()
forall (m :: * -> *). MonadOkapi m => Method -> m ()
method Method
HTTP.methodTrace

connect :: forall m. MonadOkapi m => m ()
connect :: m ()
connect = Method -> m ()
forall (m :: * -> *). MonadOkapi m => Method -> m ()
method Method
HTTP.methodConnect

options :: forall m. MonadOkapi m => m ()
options :: m ()
options = Method -> m ()
forall (m :: * -> *). MonadOkapi m => Method -> m ()
method Method
HTTP.methodOptions

patch :: forall m. MonadOkapi m => m ()
patch :: m ()
patch = Method -> m ()
forall (m :: * -> *). MonadOkapi m => Method -> m ()
method Method
HTTP.methodPatch

method :: forall m. MonadOkapi m => HTTP.Method -> m ()
method :: Method -> m ()
method Method
method = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. Show a => a -> IO ()
print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Attempting to parse method: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Method -> Text
Text.decodeUtf8 Method
method
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m ()
logic State
state
  where
    logic :: State -> m ()
    logic :: State -> m ()
logic State
state
      | State -> Bool
isMethodParsed State
state = Failure -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Method -> Bool
methodMatches State
state Method
method = Failure -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool
otherwise = do
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. Show a => a -> IO ()
print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Method parsed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Method -> Text
Text.decodeUtf8 Method
method
        State -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ State -> State
methodParsed State
state
        () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- PARSING PATHS

-- | Parses a single path segment matching the given text and discards it
seg :: forall m. MonadOkapi m => Text.Text -> m ()
seg :: Text -> m ()
seg Text
goal = (Text -> Bool) -> m ()
forall (m :: * -> *). MonadOkapi m => (Text -> Bool) -> m ()
segWith (Text
goal Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==)

-- | Parses mutiple segments matching the order of the given list and discards them
-- | TODO: Needs testing. May not have the correct behavior
segs :: forall m. MonadOkapi m => [Text.Text] -> m ()
segs :: [Text] -> m ()
segs = (Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> m ()
forall (m :: * -> *). MonadOkapi m => Text -> m ()
seg

segWith :: forall m. MonadOkapi m => (Text.Text -> Bool) -> m ()
segWith :: (Text -> Bool) -> m ()
segWith Text -> Bool
predicate = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Attempting to parse seg"
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m ()
logic State
state
  where
    logic :: State -> m ()
    logic :: State -> m ()
logic State
state
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> (Text -> Bool) -> Bool
segMatches State
state Text -> Bool
predicate = do
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Couldn't match seg"
        Failure -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool
otherwise = do
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Path parsed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> String
forall a. Show a => a -> String
show (State -> Maybe Text
getSeg State
state)
        State -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ State -> State
segParsed State
state
        () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | TODO: Change Read a constraint to custom typeclass or FromHTTPApiData
-- | Parses a single seg segment, and returns the parsed seg segment as a value of the given type
segParam :: forall a m. (MonadOkapi m, Web.FromHttpApiData a) => m a
segParam :: m a
segParam = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Attempting to get param from seg"
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m a
logic State
state
  where
    logic :: State -> m a
    logic :: State -> m a
logic State
state =
      case State -> Maybe Text
getSeg State
state Maybe Text -> (Text -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe a
forall a. FromHttpApiData a => Text -> Maybe a
Web.parseUrlPieceMaybe of
        Maybe a
Nothing -> Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
        Just a
value -> do
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Path param parsed"
          State -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ State -> State
segParsed State
state
          a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value

-- | Matches entire remaining path or fails
path :: forall m. MonadOkapi m => [Text.Text] -> m ()
path :: [Text] -> m ()
path [Text]
pathMatch = do
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m ()
logic State
state
  where
    logic :: State -> m ()
    logic :: State -> m ()
logic State
state
      | State -> [Text]
getPath State
state [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Text]
pathMatch = Failure -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool
otherwise = do
        State -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ State -> State
pathParsed State
state
        () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- PARSING QUERY PARAMETERS

-- | Parses a query parameter with the given name and returns the value as the given type
queryParam :: forall a m. (MonadOkapi m, Web.FromHttpApiData a) => Text.Text -> m a
queryParam :: Text -> m a
queryParam Text
key = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. Show a => a -> IO ()
print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Attempting to get query param " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m a
logic State
state
  where
    logic :: State -> m a
    logic :: State -> m a
logic State
state
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isMethodParsed State
state = Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isPathParsed State
state = Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool
otherwise =
        case State -> (Text -> Bool) -> Maybe QueryItem
getQueryItem State
state (Text
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) of
          Maybe QueryItem
Nothing -> Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
          Just QueryItem
queryItem -> case QueryItem
queryItem of
            (Text
_, Maybe Text
Nothing) ->
              Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
            (Text
_, Just Text
param) -> case Text -> Maybe a
forall a. FromHttpApiData a => Text -> Maybe a
Web.parseQueryParamMaybe Text
param of
              Maybe a
Nothing ->
                Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
              Just a
value -> do
                IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. Show a => a -> IO ()
print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Query param parsed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
param Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
                State -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ State -> QueryItem -> State
queryParamParsed State
state QueryItem
queryItem
                a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value

queryFlag :: forall m. MonadOkapi m => Text.Text -> m Bool
queryFlag :: Text -> m Bool
queryFlag Text
key = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. Show a => a -> IO ()
print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Checking if query param exists " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m Bool
logic State
state
  where
    logic :: State -> m Bool
    logic :: State -> m Bool
logic State
state
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isMethodParsed State
state = Failure -> m Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isPathParsed State
state = Failure -> m Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool
otherwise =
        case State -> (Text -> Bool) -> Maybe QueryItem
getQueryItem State
state (Text
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) of
          Maybe QueryItem
Nothing -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          Just QueryItem
queryItem -> do
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. Show a => a -> IO ()
print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Query param exists: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key
            State -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ State -> QueryItem -> State
queryParamParsed State
state QueryItem
queryItem
            Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

-- PARSING HEADERS

header :: forall m. MonadOkapi m => HTTP.HeaderName -> m Text.Text
header :: HeaderName -> m Text
header HeaderName
headerName = do
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m Text
logic State
state
  where
    logic :: State -> m Text.Text
    logic :: State -> m Text
logic State
state =
      case State -> HeaderName -> Maybe Header
getHeader State
state HeaderName
headerName of
        Maybe Header
Nothing -> Failure -> m Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
        Just header :: Header
header@(HeaderName
name, Method
value) -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Method -> Text
Text.decodeUtf8 Method
value

auth :: forall m. MonadOkapi m => m Text.Text
auth :: m Text
auth = HeaderName -> m Text
forall (m :: * -> *). MonadOkapi m => HeaderName -> m Text
header HeaderName
"Authorization"

basicAuth :: forall m. MonadOkapi m => m (Text.Text, Text.Text)
basicAuth :: m (Text, Text)
basicAuth = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Attempting to get basic auth from headers"
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m (Text, Text)
logic State
state
  where
    logic :: State -> m (Text.Text, Text.Text)
    logic :: State -> m (Text, Text)
logic State
state = do
      case State -> HeaderName -> Maybe Header
getHeader State
state HeaderName
"Authorization" of
        Maybe Header
Nothing -> Failure -> m (Text, Text)
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
        Just header :: Header
header@(HeaderName
_, Method
authValue) -> do
          case Method -> [Method]
Char8.words Method
authValue of
            [Method
"Basic", Method
encodedCreds] -> case Method -> Either Text Method
Base64.decodeBase64 Method
encodedCreds of
              Left Text
_ -> Failure -> m (Text, Text)
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
              Right Method
decodedCreds -> case Char -> Method -> [Method]
Char8.split Char
':' Method
decodedCreds of
                [Method
userID, Method
password] -> do
                  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Basic auth acquired"
                  State -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ State -> Header -> State
headerParsed State
state Header
header
                  (Text, Text) -> m (Text, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text, Text) -> m (Text, Text)) -> (Text, Text) -> m (Text, Text)
forall a b. (a -> b) -> a -> b
$ (Method -> Text)
-> (Method -> Text) -> (Method, Method) -> (Text, Text)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Bifunctor.bimap Method -> Text
Text.decodeUtf8 Method -> Text
Text.decodeUtf8 (Method
userID, Method
password)
                [Method]
_ -> Failure -> m (Text, Text)
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
            [Method]
_ -> Failure -> m (Text, Text)
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip

-- PARSING BODY

-- TODO: Check HEADERS for correct content type?
-- TODO: Check METHOD for correct HTTP method?

bodyJSON :: forall a m. (MonadOkapi m, Aeson.FromJSON a) => m a
bodyJSON :: m a
bodyJSON = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Attempting to parse JSON body"
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m a
logic State
state
  where
    logic :: State -> m a
    logic :: State -> m a
logic State
state
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isMethodParsed State
state = Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isPathParsed State
state = Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool
otherwise =
        do
          ByteString
body <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ State -> IO ByteString
getRequestBody State
state
          case ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
body of
            Maybe a
Nothing -> do
              IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Couldn't parse " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
body
              Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
            Just a
value -> do
              IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"JSON body parsed"
              State -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ State -> State
bodyParsed State
state
              a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value

bodyForm :: forall a m. (MonadOkapi m, Web.FromForm a) => m a
bodyForm :: m a
bodyForm = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Attempting to parse FormURLEncoded body"
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m a
logic State
state
  where
    logic :: State -> m a
    logic :: State -> m a
logic State
state
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isMethodParsed State
state = Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isPathParsed State
state = Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool
otherwise =
        do
          ByteString
body <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ State -> IO ByteString
getRequestBody State
state
          case 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
$ ByteString -> Either Text a
forall a. FromForm a => ByteString -> Either Text a
Web.urlDecodeAsForm ByteString
body of
            Maybe a
Nothing -> Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
            Just a
value -> do
              IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"FormURLEncoded body parsed"
              State -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> m ()) -> State -> m ()
forall a b. (a -> b) -> a -> b
$ State -> State
bodyParsed State
state
              a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value

-- TODO: bodyFile functions for file uploads to server

-- RESPONSE FUNCTIONS

respond :: forall m. MonadOkapi m => Natural.Natural -> Headers -> LazyByteString.ByteString -> m Result
respond :: Natural -> ResponseHeaders -> ByteString -> m Result
respond Natural
status ResponseHeaders
headers ByteString
body = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Attempting to respond from Servo"
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m Result
logic State
state
  where
    logic :: State -> m Result
    logic :: State -> m Result
logic State
state
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isMethodParsed State
state = Failure -> m Result
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isPathParsed State
state = Failure -> m Result
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isQueryParamsParsed State
state = Failure -> m Result
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      -- not $ isBodyParsed request = Except.throwError Skip
      | Bool
otherwise = do
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Responded from servo, passing off to WAI"
        Result -> m Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> m Result) -> Result -> m Result
forall a b. (a -> b) -> a -> b
$ Response -> Result
ResultResponse (Response -> Result) -> Response -> Result
forall a b. (a -> b) -> a -> b
$ Natural -> ResponseHeaders -> ByteString -> Response
Response Natural
status ResponseHeaders
headers ByteString
body

-- TODO: Use response builder?
okHTML :: forall m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m Result
okHTML :: ResponseHeaders -> ByteString -> m Result
okHTML ResponseHeaders
headers = Natural -> ResponseHeaders -> ByteString -> m Result
forall (m :: * -> *).
MonadOkapi m =>
Natural -> ResponseHeaders -> ByteString -> m Result
respond Natural
200 ([(HeaderName
"Content-Type", Method
"text/html")] ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
headers)

okPlainText :: forall m. MonadOkapi m => Headers -> Text.Text -> m Result
okPlainText :: ResponseHeaders -> Text -> m Result
okPlainText ResponseHeaders
headers = Natural -> ResponseHeaders -> ByteString -> m Result
forall (m :: * -> *).
MonadOkapi m =>
Natural -> ResponseHeaders -> ByteString -> m Result
respond Natural
200 ([(HeaderName
"Content-Type", Method
"text/plain")] ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
headers) (ByteString -> m Result)
-> (Text -> ByteString) -> Text -> m Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> ByteString
LazyByteString.fromStrict (Method -> ByteString) -> (Text -> Method) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Method
Text.encodeUtf8

okJSON :: forall a m. (MonadOkapi m, Aeson.ToJSON a) => Headers -> a -> m Result
okJSON :: ResponseHeaders -> a -> m Result
okJSON ResponseHeaders
headers = Natural -> ResponseHeaders -> ByteString -> m Result
forall (m :: * -> *).
MonadOkapi m =>
Natural -> ResponseHeaders -> ByteString -> m Result
respond Natural
200 ([(HeaderName
"Content-Type", Method
"application/json")] ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
headers) (ByteString -> m Result) -> (a -> ByteString) -> a -> m Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode

okLucid :: forall a m. (MonadOkapi m, Lucid.ToHtml a) => Headers -> a -> m Result
okLucid :: ResponseHeaders -> a -> m Result
okLucid ResponseHeaders
headers = ResponseHeaders -> ByteString -> m Result
forall (m :: * -> *).
MonadOkapi m =>
ResponseHeaders -> ByteString -> m Result
okHTML ResponseHeaders
headers (ByteString -> m Result) -> (a -> ByteString) -> a -> m Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html () -> ByteString
forall a. Html a -> ByteString
Lucid.renderBS (Html () -> ByteString) -> (a -> Html ()) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
Lucid.toHtml

noContent :: forall a m. MonadOkapi m => Headers -> m Result
noContent :: ResponseHeaders -> m Result
noContent ResponseHeaders
headers = Natural -> ResponseHeaders -> ByteString -> m Result
forall (m :: * -> *).
MonadOkapi m =>
Natural -> ResponseHeaders -> ByteString -> m Result
respond Natural
204 ResponseHeaders
headers ByteString
""

redirectTo :: forall a m. MonadOkapi m => Char8.ByteString -> m Result
redirectTo :: Method -> m Result
redirectTo Method
url = Natural -> ResponseHeaders -> ByteString -> m Result
forall (m :: * -> *).
MonadOkapi m =>
Natural -> ResponseHeaders -> ByteString -> m Result
respond Natural
302 [(HeaderName
"Location", Method
url)] ByteString
""

-- File Responses

file :: forall m. MonadOkapi m => Natural.Natural -> Headers -> FilePath -> m Result
file :: Natural -> ResponseHeaders -> String -> m Result
file Natural
status ResponseHeaders
headers String
filePath = do
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m Result
logic State
state
  where
    logic :: State -> m Result
    logic :: State -> m Result
logic State
state
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isMethodParsed State
state = Failure -> m Result
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isPathParsed State
state = Failure -> m Result
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isQueryParamsParsed State
state = Failure -> m Result
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      -- not $ isBodyParsed request = Except.throwError Skip
      | Bool
otherwise = do
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Responded from servo, passing off to WAI"
        Result -> m Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> m Result) -> Result -> m Result
forall a b. (a -> b) -> a -> b
$ File -> Result
ResultFile (File -> Result) -> File -> Result
forall a b. (a -> b) -> a -> b
$ Natural -> ResponseHeaders -> String -> File
File Natural
status ResponseHeaders
headers String
filePath

okFile :: forall m. MonadOkapi m => Headers -> FilePath -> m Result
okFile :: ResponseHeaders -> String -> m Result
okFile ResponseHeaders
headers = Natural -> ResponseHeaders -> String -> m Result
forall (m :: * -> *).
MonadOkapi m =>
Natural -> ResponseHeaders -> String -> m Result
file Natural
200 ResponseHeaders
headers

-- Event Source Responses

connectEventSource :: forall m. MonadOkapi m => EventSource.EventSource -> m Result
connectEventSource :: EventSource -> m Result
connectEventSource EventSource
eventSource = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Attempting to connect SSE source from Servo"
  State
state <- m State
forall s (m :: * -> *). MonadState s m => m s
State.get
  State -> m Result
logic State
state
  where
    logic :: State -> m Result
    logic :: State -> m Result
logic State
state
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isMethodParsed State
state = Failure -> m Result
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isPathParsed State
state = Failure -> m Result
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Bool
isQueryParamsParsed State
state = Failure -> m Result
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Failure
Skip
      -- not $ isBodyParsed request = Except.throwError Skip
      | Bool
otherwise = do
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print String
"Responded from servo, passing off to WAI"
        Result -> m Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> m Result) -> Result -> m Result
forall a b. (a -> b) -> a -> b
$ EventSource -> Result
ResultEventSource EventSource
eventSource

-- ERROR FUNCTIONS

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

error :: forall a m. MonadOkapi m => Natural.Natural -> Headers -> LazyByteString.ByteString -> m a
error :: Natural -> ResponseHeaders -> ByteString -> m a
error Natural
status ResponseHeaders
headers = Failure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError (Failure -> m a) -> (ByteString -> Failure) -> ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Failure
Error (Response -> Failure)
-> (ByteString -> Response) -> ByteString -> Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> ResponseHeaders -> ByteString -> Response
Response Natural
status ResponseHeaders
headers

error500 :: forall a m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m a
error500 :: ResponseHeaders -> ByteString -> m a
error500 = Natural -> ResponseHeaders -> ByteString -> m a
forall a (m :: * -> *).
MonadOkapi m =>
Natural -> ResponseHeaders -> ByteString -> m a
error Natural
500

error401 :: forall a m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m a
error401 :: ResponseHeaders -> ByteString -> m a
error401 = Natural -> ResponseHeaders -> ByteString -> m a
forall a (m :: * -> *).
MonadOkapi m =>
Natural -> ResponseHeaders -> ByteString -> m a
error Natural
401

error403 :: forall a m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m a
error403 :: ResponseHeaders -> ByteString -> m a
error403 = Natural -> ResponseHeaders -> ByteString -> m a
forall a (m :: * -> *).
MonadOkapi m =>
Natural -> ResponseHeaders -> ByteString -> m a
error Natural
403

error404 :: forall a m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m a
error404 :: ResponseHeaders -> ByteString -> m a
error404 = Natural -> ResponseHeaders -> ByteString -> m a
forall a (m :: * -> *).
MonadOkapi m =>
Natural -> ResponseHeaders -> ByteString -> m a
error Natural
404

error422 :: forall a m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m a
error422 :: ResponseHeaders -> ByteString -> m a
error422 = Natural -> ResponseHeaders -> ByteString -> m a
forall a (m :: * -> *).
MonadOkapi m =>
Natural -> ResponseHeaders -> ByteString -> m a
error Natural
422

-- | Execute the next parser even if the first one throws an Error 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)

optionalError :: MonadOkapi m => m a -> m (Maybe a)
optionalError :: m a -> m (Maybe a)
optionalError m a
parser = (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
parser) m (Maybe a) -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadOkapi m => m a -> m a -> m a
<!> Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

optionError :: MonadOkapi m => a -> m a -> m a
optionError :: a -> m a -> m a
optionError a
value m a
parser = do
  Maybe a
mbValue <- m a -> m (Maybe a)
forall (m :: * -> *) a. MonadOkapi m => m a -> m (Maybe a)
optionalError m a
parser
  case Maybe a
mbValue of
    Maybe a
Nothing -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value
    Just a
value' -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value'

-- PARSING GUARDS AND SWITCHES

isMethodParsed :: State -> Bool
isMethodParsed :: State -> Bool
isMethodParsed State {Bool
Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
stateRequestBodyParsed :: State -> Bool
stateRequestMethodParsed :: State -> Bool
stateRequest :: State -> Request
..} = Bool
stateRequestMethodParsed

isPathParsed :: State -> Bool
isPathParsed :: State -> Bool
isPathParsed State {Bool
Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
stateRequestBodyParsed :: State -> Bool
stateRequestMethodParsed :: State -> Bool
stateRequest :: State -> Request
..} = [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
requestPath Request
stateRequest

isQueryParamsParsed :: State -> Bool
isQueryParamsParsed :: State -> Bool
isQueryParamsParsed State {Bool
Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
stateRequestBodyParsed :: State -> Bool
stateRequestMethodParsed :: State -> Bool
stateRequest :: State -> Request
..} = QueryText -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null (QueryText -> Bool) -> QueryText -> Bool
forall a b. (a -> b) -> a -> b
$ Request -> QueryText
requestQuery Request
stateRequest

isBodyParsed :: State -> Bool
isBodyParsed :: State -> Bool
isBodyParsed State {Bool
Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
stateRequestBodyParsed :: State -> Bool
stateRequestMethodParsed :: State -> Bool
stateRequest :: State -> Request
..} = Bool
stateRequestBodyParsed

methodMatches :: State -> HTTP.Method -> Bool
methodMatches :: State -> Method -> Bool
methodMatches State {Bool
Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
stateRequestBodyParsed :: State -> Bool
stateRequestMethodParsed :: State -> Bool
stateRequest :: State -> Request
..} Method
method = Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Request -> Method
requestMethod Request
stateRequest

segMatches :: State -> (Text.Text -> Bool) -> Bool
segMatches :: State -> (Text -> Bool) -> Bool
segMatches State
state Text -> Bool
predicate =
  Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Text -> Bool
predicate (Maybe Text -> Bool) -> Maybe Text -> Bool
forall a b. (a -> b) -> a -> b
$ State -> Maybe Text
getSeg State
state

getPath :: State -> [Text.Text]
getPath :: State -> [Text]
getPath State {Bool
Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
stateRequestBodyParsed :: State -> Bool
stateRequestMethodParsed :: State -> Bool
stateRequest :: State -> Request
..} = Request -> [Text]
requestPath Request
stateRequest

getSeg :: State -> Maybe Text.Text
getSeg :: State -> Maybe Text
getSeg State {Bool
Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
stateRequestBodyParsed :: State -> Bool
stateRequestMethodParsed :: State -> Bool
stateRequest :: State -> Request
..} = [Text] -> Maybe Text
forall a. [a] -> Maybe a
safeHead (Request -> [Text]
requestPath Request
stateRequest)

getQueryItem :: State -> (Text.Text -> Bool) -> Maybe QueryItem
getQueryItem :: State -> (Text -> Bool) -> Maybe QueryItem
getQueryItem State {Bool
Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
stateRequestBodyParsed :: State -> Bool
stateRequestMethodParsed :: State -> Bool
stateRequest :: State -> Request
..} Text -> Bool
predicate = (QueryItem -> Bool) -> QueryText -> Maybe QueryItem
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Foldable.find (\(Text
key, Maybe Text
_) -> Text -> Bool
predicate Text
key) (Request -> QueryText
requestQuery Request
stateRequest)

getHeader :: State -> HTTP.HeaderName -> Maybe HTTP.Header
getHeader :: State -> HeaderName -> Maybe Header
getHeader State {Bool
Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
stateRequestBodyParsed :: State -> Bool
stateRequestMethodParsed :: State -> Bool
stateRequest :: State -> Request
..} HeaderName
key = (Header -> Bool) -> ResponseHeaders -> Maybe Header
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Foldable.find (\(HeaderName
key', Method
_) -> HeaderName
key HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
key') (Request -> ResponseHeaders
requestHeaders Request
stateRequest)

getRequestBody :: State -> IO LazyByteString.ByteString
getRequestBody :: State -> IO ByteString
getRequestBody State {Bool
Request
stateRequestBodyParsed :: Bool
stateRequestMethodParsed :: Bool
stateRequest :: Request
stateRequestBodyParsed :: State -> Bool
stateRequestMethodParsed :: State -> Bool
stateRequest :: State -> Request
..} = Request -> IO ByteString
requestBody Request
stateRequest

methodParsed :: State -> State
methodParsed :: State -> State
methodParsed State
state = State
state {stateRequestMethodParsed :: Bool
stateRequestMethodParsed = Bool
True}

segParsed :: State -> State
segParsed :: State -> State
segParsed State
state = State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestPath :: [Text]
requestPath = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
Prelude.drop Int
1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
requestPath (Request -> [Text]) -> Request -> [Text]
forall a b. (a -> b) -> a -> b
$ State -> Request
stateRequest State
state}}

pathParsed :: State -> State
pathParsed :: State -> State
pathParsed State
state = State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestPath :: [Text]
requestPath = []}}

queryParamParsed :: State -> QueryItem -> State
queryParamParsed :: State -> QueryItem -> State
queryParamParsed State
state QueryItem
queryItem = State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestQuery :: QueryText
requestQuery = QueryItem -> QueryText -> QueryText
forall a. Eq a => a -> [a] -> [a]
List.delete QueryItem
queryItem (QueryText -> QueryText) -> QueryText -> QueryText
forall a b. (a -> b) -> a -> b
$ Request -> QueryText
requestQuery (Request -> QueryText) -> Request -> QueryText
forall a b. (a -> b) -> a -> b
$ State -> Request
stateRequest State
state}}

-- TODO: Don't List.delete header??
headerParsed :: State -> HTTP.Header -> State
headerParsed :: State -> Header -> State
headerParsed State
state Header
header = State
state {stateRequest :: Request
stateRequest = (State -> Request
stateRequest State
state) {requestHeaders :: ResponseHeaders
requestHeaders = Header -> ResponseHeaders -> ResponseHeaders
forall a. Eq a => a -> [a] -> [a]
List.delete Header
header (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders (Request -> ResponseHeaders) -> Request -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ State -> Request
stateRequest State
state}}

bodyParsed :: State -> State
bodyParsed :: State -> State
bodyParsed State
state = State
state {stateRequestBodyParsed :: Bool
stateRequestBodyParsed = Bool
True}

-- HELPERS

eitherToMaybe :: Either l r -> Maybe r
eitherToMaybe :: Either l r -> Maybe r
eitherToMaybe (Left l
_) = Maybe r
forall a. Maybe a
Nothing
eitherToMaybe (Right r
x) = r -> Maybe r
forall a. a -> Maybe a
Just r
x

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

lookupBy :: forall a b. (a -> Bool) -> [(a, b)] -> Maybe b
lookupBy :: (a -> Bool) -> [(a, b)] -> Maybe b
lookupBy a -> Bool
_ [] = Maybe b
forall a. Maybe a
Nothing
lookupBy a -> Bool
predicate ((a
x, b
y) : [(a, b)]
xys)
  | a -> Bool
predicate a
x = b -> Maybe b
forall a. a -> Maybe a
Just b
y
  | Bool
otherwise = (a -> Bool) -> [(a, b)] -> Maybe b
forall a b. (a -> Bool) -> [(a, b)] -> Maybe b
lookupBy a -> Bool
predicate [(a, b)]
xys