packages feed

okapi (empty) → 0.1.0.0

raw patch · 10 files changed

+1213/−0 lines, 10 filesdep +aesondep +basedep +base64setup-changed

Dependencies added: aeson, base, base64, bytestring, containers, http-api-data, http-types, lucid, mmorph, mtl, okapi, random, stm, text, transformers, unagi-chan, uuid, vault, wai, wai-extra, warp, warp-tls

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for okapi++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,200 @@+# Okapi++A microframework based on monadic parsing. Official documentation [here](https://www.okapi.wiki/).++![Okapi mascot](https://github.com/MonadicSystems/okapi/blob/main/okapi_1_50.png?raw=true)++## Introduction++**Okapi** is a microframework for building web servers in [Haskell](https://haskell.org) based on *monadic parsing*.+In contrast to other web frameworks in the Haskell ecosystem, Okapi is primarily concerned with being easy to understand and use, instead of extreme type safety.+Here's an example of a simple web server:++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Data.Text+import Okapi++main :: IO ()+main = runOkapi id 3000 greet++greet = do+  seg "greet"+  name <- segParam+  respondPlainText [] $ "Hello " <> name <> "! I'm Okapi."+```++Running this code will start a server on [localhost:3000](http://localhost:3000.org).+If you go to [http://localhost:3000/greeting/Bob]() the server will respond with `Hello Bob! I'm Okapi.` in plain text format.++Okapi is a [monadic parser](https://www.cs.nott.ac.uk/~pszgmh/monparsing.pdf) for HTTP requests. This means it can be used with all `Applicative`, `Alternative`, and `Monad` typeclass methods, plus other Haskell idioms like [parser combinators](https://hackage.haskell.org/package/parser-combinators).++Here's a more complicated example that implements a calculator API. Type annotations are added to make the code easier to follow:++```haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Control.Applicative ((<|>))+import Data.Aeson (ToJSON)+import Data.Text+import GHC.Generics (Generic)+import Okapi+++main :: IO ()+main = runOkapi id 3000 calc++type Okapi a = OkapiT IO a++calc :: Okapi Response+calc = do+  get+  seg "calc"+  addOp <|> subOp <|> mulOp <|> divOp++addOp :: Okapi Response+addOp = do+  seg "add"+  (x, y) <- getArgs+  respondJSON [] $ x + y++subOp :: Okapi Response+subOp = do+  seg "sub" <|> seg "minus"+  (x, y) <- getArgs+  respondJSON [] $ x - y++mulOp :: Okapi Response+mulOp = do+  seg "mul"+  (x, y) <- getArgs+  respondJSON [] $ x * y++data DivResult = DivResult+  { answer :: Int,+    remainder :: Int+  }+  deriving (Eq, Show, Generic, ToJSON)++divOp :: Okapi Response+divOp = do+  seg "div"+  (x, y) <- getArgs+  if y == 0+    then error403 [] "Forbidden"+    else respondJSON [] $ DivResult {answer = x `div` y, remainder = x `mod` y}++getArgs :: Okapi (Int, Int)+getArgs = getArgsFromPath <|> getArgsFromQueryParams+  where+    getArgsFromPath :: Okapi (Int, Int)+    getArgsFromPath = do+      x <- segParamAs @Int+      y <- segParamAs @Int+      pure (x, y)++    getArgsFromQueryParams :: Okapi (Int, Int)+    getArgsFromQueryParams = do+      x <- queryParamAs @Int "x"+      y <- queryParamAs @Int "y"+      pure (x, y)+```++Okapi is very flexible. You could also define the above without `do` notation or type annotations:++```haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Control.Applicative ((<|>))+import Control.Monad.Combinators (choice)+import Data.Aeson (ToJSON)+import Data.Text+import GHC.Generics (Generic)+import Okapi++main :: IO ()+main = runOkapi id 3000 calcNoDo++calcNoDo = get >> seg "calc" >> choice [addOp, subOp, mulOp, divOp]++addOp = seg "add" >> (getArgs >>= (\(x, y) -> respondJSON [] $ x + y))++subOp = (seg "sub" <|> seg "minus") >> (getArgs >>= (\(x, y) -> respondJSON [] $ x - y))++mulOp = seg "mul" >> (getArgs >>= (\(x, y) -> respondJSON [] $ x * y))++data DivResult = DivResult+  { answer :: Int,+    remainder :: Int+  }+  deriving (Eq, Show, Generic, ToJSON)++divOp = seg "div" >> (getArgs >>= (\(x, y) -> if y == 0 then error403 [] "Forbidden" else respondJSON [] $ DivResult (x `div` y) (x `mod` y)))++getArgs = getArgsFromPath <|> getArgsFromQueryParams+  where+    getArgsFromPath = segParamAs @Int >>= (\x -> segParamAs @Int >>= (\y -> pure (x, y)))+    getArgsFromQueryParams = queryParamAs @Int "x" >>= (\x -> queryParamAs @Int "y" >>= (\y -> pure (x, y)))+```++Don't like monads at all? You can use Okapi as an [applicative parser](https://eli.thegreenplace.net/2017/deciphering-haskells-applicative-and-monadic-parsers/) too:++```haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Control.Applicative (liftA2, (<|>))+import Control.Applicative.Combinators (choice)+import Data.Aeson (ToJSON)+import Data.Text+import GHC.Generics (Generic)+import Okapi++main :: IO ()+main = runOkapi id 3000 calcAp++calcAp = get *> seg "calc" *> choice [addOp, subOp, mulOp, divOp]++addOp = seg "add" *> respondJSONAp [] (uncurry (+) <$> getArgs)++subOp = (seg "sub" <|> seg "minus") *> respondJSONAp [] (uncurry (-) <$> getArgs)++mulOp = seg "mul" *> respondJSONAp [] (uncurry (*) <$> getArgs)++data DivResult = DivResult+  { answer :: Int,+    remainder :: Int+  }+  deriving (Eq, Show, Generic, ToJSON)++divOp = seg "div" *> (getArgs >>= (\(x, y) -> if y == 0 then error403 [] "Forbidden" else respondJSON [] $ DivResult (x `div` y) (x `mod` y)))++getArgs = getArgsFromPath <|> getArgsFromQueryParams+  where+    getArgsFromPath = liftA2 (,) (segParamAs @Int) (segParamAs @Int)+    getArgsFromQueryParams = liftA2 (,) (queryParamAs @Int "x") (queryParamAs @Int "y")++```++As you can see, Okapi's parsing functions are very modular and can be easily composed with one another to create parsing primitives tailored specifically to your needs.+With Okapi, and the rest of the amazing Haskell ecosystem, you can create anything from simple website servers to complex APIs for web apps.+All you need to get started is basic knowledge about the structure of HTTP requests and an idea of how monadic parsing works.++## Contributing++Help is needed! There are issues and project board. Look there or open an issue or PR. There are no barriers. Any kind of help is welcome.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ okapi.cabal view
@@ -0,0 +1,87 @@+cabal-version:      1.12+name:               okapi+version:            0.1.0.0+license:            BSD3+license-file:       LICENSE+copyright:          2022 Monadic Systems LLC+maintainer:         tech@monadic.systems+author:             Monadic Systems LLC+homepage:           https://github.com/githubuser/okapi#readme+bug-reports:        https://github.com/githubuser/okapi/issues+synopsis:           A microframework based on monadic parsing+description:+    Please see the README on GitHub at <https://github.com/githubuser/okapi#readme>++category:           Web+build-type:         Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+    type:     git+    location: https://github.com/githubuser/okapi++library+    exposed-modules:+        Okapi+        Okapi.EventSource+        Okapi.Function+        Okapi.Type++    hs-source-dirs:   src+    other-modules:    Paths_okapi+    default-language: Haskell2010+    build-depends:+        aeson >=2.0.3.0 && <2.1,+        base >=4.7 && <5,+        base64 >=0.4.2.3 && <0.5,+        bytestring >=0.10.12.1 && <0.11,+        containers >=0.6.4.1 && <0.7,+        http-api-data >=0.4.3 && <0.5,+        http-types >=0.12.3 && <0.13,+        lucid >=2.11.0 && <2.12,+        mmorph >=1.1.5 && <1.2,+        mtl >=2.2.2 && <2.3,+        random >=1.2.1 && <1.3,+        stm >=2.5.0.0 && <2.6,+        text >=1.2.5.0 && <1.3,+        transformers >=0.5.6.2 && <0.6,+        unagi-chan >=0.4.1.4 && <0.5,+        uuid >=1.3.15 && <1.4,+        vault >=0.3.1.5 && <0.4,+        wai >=3.2.3 && <3.3,+        wai-extra >=3.1.8 && <3.2,+        warp >=3.3.20 && <3.4,+        warp-tls >=3.3.2 && <3.4++test-suite okapi-test+    type:             exitcode-stdio-1.0+    main-is:          Spec.hs+    hs-source-dirs:   test+    other-modules:    Paths_okapi+    default-language: Haskell2010+    ghc-options:      -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        aeson >=2.0.3.0 && <2.1,+        base >=4.7 && <5,+        base64 >=0.4.2.3 && <0.5,+        bytestring >=0.10.12.1 && <0.11,+        containers >=0.6.4.1 && <0.7,+        http-api-data >=0.4.3 && <0.5,+        http-types >=0.12.3 && <0.13,+        lucid >=2.11.0 && <2.12,+        mmorph >=1.1.5 && <1.2,+        mtl >=2.2.2 && <2.3,+        okapi -any,+        random >=1.2.1 && <1.3,+        stm >=2.5.0.0 && <2.6,+        text >=1.2.5.0 && <1.3,+        transformers >=0.5.6.2 && <0.6,+        unagi-chan >=0.4.1.4 && <0.5,+        uuid >=1.3.15 && <1.4,+        vault >=0.3.1.5 && <0.4,+        wai >=3.2.3 && <3.3,+        wai-extra >=3.1.8 && <3.2,+        warp >=3.3.20 && <3.4,+        warp-tls >=3.3.2 && <3.4
+ src/Okapi.hs view
@@ -0,0 +1,12 @@+module Okapi+  ( module Okapi.Function,+    OkapiT (..),+    MonadOkapi (..),+    Result,+    module Okapi.EventSource+  )+where++import Okapi.Function+import Okapi.Type+import Okapi.EventSource
+ src/Okapi/EventSource.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}++module Okapi.EventSource+  ( ToSSE (..)+  , Event (..)+  , EventSource+  , newEventSource+  , sendEvent+  , sendValue+  , eventSourceAppUnagiChan+  )+where++import qualified Control.Concurrent.Chan.Unagi as Unagi+import qualified Control.Monad.IO.Class as IO+-- import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as ByteString+import qualified Data.ByteString.Builder as Builder+import qualified Data.Function as Function+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.UUID as UUID+import qualified Data.UUID.V4 as UUID+import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Types.Status as HTTP+import qualified Network.Wai as Wai+import qualified Network.Wai.EventSource as EventSource++class ToSSE a where+  toSSE :: a -> Event++data Event+  = Event+      { eventName :: Maybe Text.Text,+        eventID :: Maybe Text.Text,+        eventData :: ByteString.ByteString+      }+  | CommentEvent ByteString.ByteString+  | CloseEvent+  deriving (Show, Eq)++type Chan a = (Unagi.InChan a, Unagi.OutChan a)++type EventSource = Chan Event++newEventSource :: IO EventSource+newEventSource = Unagi.newChan++sendValue :: ToSSE a => EventSource -> a -> IO ()+sendValue (inChan, _outChan) = Unagi.writeChan inChan . toSSE++sendEvent :: EventSource -> Event -> IO ()+sendEvent (inChan, _outChan) = Unagi.writeChan inChan++eventSourceAppUnagiChan :: Chan Event -> Wai.Application+eventSourceAppUnagiChan (inChan, _outChan) req sendResponse = do+  outChan <- IO.liftIO $ Unagi.dupChan inChan+  eventSourceAppIO (eventToServerEvent <$> Unagi.readChan outChan) req sendResponse++eventSourceAppIO :: IO EventSource.ServerEvent -> Wai.Application+eventSourceAppIO src _ sendResponse =+  sendResponse $+    Wai.responseStream+      HTTP.status200+      [(HTTP.hContentType, "text/event-stream")]+      $ \sendChunk flush -> do+        flush+        Function.fix $ \loop -> do+          se <- src+          case eventToBuilder se of+            Nothing -> return ()+            Just b -> sendChunk b >> flush >> loop++eventToBuilder :: EventSource.ServerEvent -> Maybe Builder.Builder+eventToBuilder (EventSource.CommentEvent txt) = Just $ field commentField txt+eventToBuilder (EventSource.RetryEvent n) = Just $ field retryField (Builder.string8 . show $ n)+eventToBuilder EventSource.CloseEvent = Nothing+eventToBuilder (EventSource.ServerEvent n i d) =+  Just $+    mappend (name n (evid i $ evdata (mconcat d) nl)) nl+  where+    name Nothing = id+    name (Just n') = mappend (field nameField n')+    evid Nothing = id+    evid (Just i') = mappend (field idField i')+    evdata d' = mappend (field dataField d')++nl :: Builder.Builder+nl = Builder.char7 '\n'++nameField, idField, dataField, retryField, commentField :: Builder.Builder+nameField = Builder.string7 "event:"+idField = Builder.string7 "id:"+dataField = Builder.string7 "data:"+retryField = Builder.string7 "retry:"+commentField = Builder.char7 ':'++-- | Wraps the text as a labeled field of an event stream.+field :: Builder.Builder -> Builder.Builder -> Builder.Builder+field l b = l `mappend` b `mappend` nl++eventToServerEvent :: Event -> EventSource.ServerEvent+eventToServerEvent Event {..} =+  EventSource.ServerEvent+    (Builder.byteString . Text.encodeUtf8 <$> eventName)+    (Builder.byteString . Text.encodeUtf8 <$> eventID)+    (Builder.word8 <$> ByteString.unpack eventData)+eventToServerEvent (CommentEvent comment) = EventSource.CommentEvent $ Builder.lazyByteString comment+eventToServerEvent CloseEvent = EventSource.CloseEvent
+ src/Okapi/Function.hs view
@@ -0,0 +1,570 @@+{-# 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 hoister port okapiT = do+  print $ "Running Okapi App on port " <> show port+  Warp.run port $ makeOkapiApp hoister okapiT++runOkapiTLS :: Monad m => (forall a. m a -> IO a) -> Warp.TLSSettings -> Warp.Settings -> OkapiT m Result -> IO ()+runOkapiTLS hoister tlsSettings settings okapiT = do+  print "Running servo on port 43"+  Warp.runTLS tlsSettings settings $ makeOkapiApp hoister okapiT++makeOkapiApp :: Monad m => (forall a. m a -> IO a) -> OkapiT m Result -> Wai.Application+makeOkapiApp hoister okapiT waiRequest respond = do+  (eitherFailureOrResult, _state) <- (StateT.runStateT . ExceptT.runExceptT . unOkapiT $ Morph.hoist hoister okapiT) (waiRequestToState {-eventSourcePoolTVar-} waiRequest)+  case eitherFailureOrResult of+    Left Skip -> respond $ Wai.responseLBS HTTP.status404 [] "Not Found"+    Left (Error response) -> respond . responseToWaiResponse $ response+    Right (ResultResponse response) -> respond . responseToWaiResponse $ response+    Right (ResultFile file) -> respond . fileToWaiResponse $ file+    Right (ResultEventSource eventSource) -> (gzip def $ EventSource.eventSourceAppUnagiChan eventSource) waiRequest respond++waiRequestToState :: Wai.Request -> State+waiRequestToState waiRequest =+  let requestMethod = Wai.requestMethod waiRequest+      requestPath = Wai.pathInfo waiRequest+      requestQuery = HTTP.queryToQueryText $ Wai.queryString waiRequest+      requestBody = Wai.strictRequestBody waiRequest+      requestHeaders = Wai.requestHeaders waiRequest+      requestVault = Wai.vault waiRequest+      stateRequest = Request {..}+      stateRequestMethodParsed = False+      stateRequestBodyParsed = False+   in State {..}++responseToWaiResponse :: Response -> Wai.Response+responseToWaiResponse Response {..} = Wai.responseLBS (toEnum $ fromEnum responseStatus) responseHeaders responseBody++fileToWaiResponse :: File -> Wai.Response+fileToWaiResponse File {..} = Wai.responseFile (toEnum $ fromEnum fileStatus) fileHeaders filePath Nothing++-- PARSING METHODS++get :: forall m. MonadOkapi m => m ()+get = method HTTP.methodGet++post :: forall m. MonadOkapi m => m ()+post = method HTTP.methodPost++head :: forall m. MonadOkapi m => m ()+head = method HTTP.methodHead++put :: forall m. MonadOkapi m => m ()+put = method HTTP.methodPut++delete :: forall m. MonadOkapi m => m ()+delete = method HTTP.methodDelete++trace :: forall m. MonadOkapi m => m ()+trace = method HTTP.methodTrace++connect :: forall m. MonadOkapi m => m ()+connect = method HTTP.methodConnect++options :: forall m. MonadOkapi m => m ()+options = method HTTP.methodOptions++patch :: forall m. MonadOkapi m => m ()+patch = method HTTP.methodPatch++method :: forall m. MonadOkapi m => HTTP.Method -> m ()+method method = do+  IO.liftIO $ print $ "Attempting to parse method: " <> Text.decodeUtf8 method+  state <- State.get+  logic state+  where+    logic :: State -> m ()+    logic state+      | isMethodParsed state = Except.throwError Skip+      | not $ methodMatches state method = Except.throwError Skip+      | otherwise = do+        IO.liftIO $ print $ "Method parsed: " <> Text.decodeUtf8 method+        State.put $ methodParsed state+        pure ()++-- PARSING PATHS++-- | Parses a single path segment matching the given text and discards it+seg :: forall m. MonadOkapi m => Text.Text -> m ()+seg goal = segWith (goal ==)++-- | 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 = mapM_ seg++segWith :: forall m. MonadOkapi m => (Text.Text -> Bool) -> m ()+segWith predicate = do+  IO.liftIO $ print "Attempting to parse seg"+  state <- State.get+  logic state+  where+    logic :: State -> m ()+    logic state+      | not $ segMatches state predicate = do+        IO.liftIO $ print "Couldn't match seg"+        Except.throwError Skip+      | otherwise = do+        IO.liftIO $ print $ "Path parsed: " <> show (getSeg state)+        State.put $ segParsed state+        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 = do+  IO.liftIO $ print "Attempting to get param from seg"+  state <- State.get+  logic state+  where+    logic :: State -> m a+    logic state =+      case getSeg state >>= Web.parseUrlPieceMaybe of+        Nothing -> Except.throwError Skip+        Just value -> do+          IO.liftIO $ print "Path param parsed"+          State.put $ segParsed state+          pure value++-- | Matches entire remaining path or fails+path :: forall m. MonadOkapi m => [Text.Text] -> m ()+path pathMatch = do+  state <- State.get+  logic state+  where+    logic :: State -> m ()+    logic state+      | getPath state /= pathMatch = Except.throwError Skip+      | otherwise = do+        State.put $ pathParsed state+        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 key = do+  IO.liftIO $ print $ "Attempting to get query param " <> key+  state <- State.get+  logic state+  where+    logic :: State -> m a+    logic state+      | not $ isMethodParsed state = Except.throwError Skip+      | not $ isPathParsed state = Except.throwError Skip+      | otherwise =+        case getQueryItem state (key ==) of+          Nothing -> Except.throwError Skip+          Just queryItem -> case queryItem of+            (_, Nothing) ->+              Except.throwError Skip+            (_, Just param) -> case Web.parseQueryParamMaybe param of+              Nothing ->+                Except.throwError Skip+              Just value -> do+                IO.liftIO $ print $ "Query param parsed: " <> "(" <> key <> "," <> param <> ")"+                State.put $ queryParamParsed state queryItem+                pure value++queryFlag :: forall m. MonadOkapi m => Text.Text -> m Bool+queryFlag key = do+  IO.liftIO $ print $ "Checking if query param exists " <> key+  state <- State.get+  logic state+  where+    logic :: State -> m Bool+    logic state+      | not $ isMethodParsed state = Except.throwError Skip+      | not $ isPathParsed state = Except.throwError Skip+      | otherwise =+        case getQueryItem state (key ==) of+          Nothing -> pure False+          Just queryItem -> do+            IO.liftIO $ print $ "Query param exists: " <> key+            State.put $ queryParamParsed state queryItem+            pure True++-- PARSING HEADERS++header :: forall m. MonadOkapi m => HTTP.HeaderName -> m Text.Text+header headerName = do+  state <- State.get+  logic state+  where+    logic :: State -> m Text.Text+    logic state =+      case getHeader state headerName of+        Nothing -> Except.throwError Skip+        Just header@(name, value) -> pure $ Text.decodeUtf8 value++auth :: forall m. MonadOkapi m => m Text.Text+auth = header "Authorization"++basicAuth :: forall m. MonadOkapi m => m (Text.Text, Text.Text)+basicAuth = do+  IO.liftIO $ print "Attempting to get basic auth from headers"+  state <- State.get+  logic state+  where+    logic :: State -> m (Text.Text, Text.Text)+    logic state = do+      case getHeader state "Authorization" of+        Nothing -> Except.throwError Skip+        Just header@(_, authValue) -> do+          case Char8.words authValue of+            ["Basic", encodedCreds] -> case Base64.decodeBase64 encodedCreds of+              Left _ -> Except.throwError Skip+              Right decodedCreds -> case Char8.split ':' decodedCreds of+                [userID, password] -> do+                  IO.liftIO $ print "Basic auth acquired"+                  State.put $ headerParsed state header+                  pure $ Bifunctor.bimap Text.decodeUtf8 Text.decodeUtf8 (userID, password)+                _ -> Except.throwError Skip+            _ -> Except.throwError 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 = do+  IO.liftIO $ print "Attempting to parse JSON body"+  state <- State.get+  logic state+  where+    logic :: State -> m a+    logic state+      | not $ isMethodParsed state = Except.throwError Skip+      | not $ isPathParsed state = Except.throwError Skip+      | otherwise =+        do+          body <- IO.liftIO $ getRequestBody state+          case Aeson.decode body of+            Nothing -> do+              IO.liftIO $ print $ "Couldn't parse " <> show body+              Except.throwError Skip+            Just value -> do+              IO.liftIO $ print "JSON body parsed"+              State.put $ bodyParsed state+              pure value++bodyForm :: forall a m. (MonadOkapi m, Web.FromForm a) => m a+bodyForm = do+  IO.liftIO $ print "Attempting to parse FormURLEncoded body"+  state <- State.get+  logic state+  where+    logic :: State -> m a+    logic state+      | not $ isMethodParsed state = Except.throwError Skip+      | not $ isPathParsed state = Except.throwError Skip+      | otherwise =+        do+          body <- IO.liftIO $ getRequestBody state+          case eitherToMaybe $ Web.urlDecodeAsForm body of+            Nothing -> Except.throwError Skip+            Just value -> do+              IO.liftIO $ print "FormURLEncoded body parsed"+              State.put $ bodyParsed state+              pure value++-- TODO: bodyFile functions for file uploads to server++-- RESPONSE FUNCTIONS++respond :: forall m. MonadOkapi m => Natural.Natural -> Headers -> LazyByteString.ByteString -> m Result+respond status headers body = do+  IO.liftIO $ print "Attempting to respond from Servo"+  state <- State.get+  logic state+  where+    logic :: State -> m Result+    logic state+      | not $ isMethodParsed state = Except.throwError Skip+      | not $ isPathParsed state = Except.throwError Skip+      | not $ isQueryParamsParsed state = Except.throwError Skip+      -- not $ isBodyParsed request = Except.throwError Skip+      | otherwise = do+        IO.liftIO $ print "Responded from servo, passing off to WAI"+        pure $ ResultResponse $ Response status headers body++-- TODO: Use response builder?+okHTML :: forall m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m Result+okHTML headers = respond 200 ([("Content-Type", "text/html")] <> headers)++okPlainText :: forall m. MonadOkapi m => Headers -> Text.Text -> m Result+okPlainText headers = respond 200 ([("Content-Type", "text/plain")] <> headers) . LazyByteString.fromStrict . Text.encodeUtf8++okJSON :: forall a m. (MonadOkapi m, Aeson.ToJSON a) => Headers -> a -> m Result+okJSON headers = respond 200 ([("Content-Type", "application/json")] <> headers) . Aeson.encode++okLucid :: forall a m. (MonadOkapi m, Lucid.ToHtml a) => Headers -> a -> m Result+okLucid headers = okHTML headers . Lucid.renderBS . Lucid.toHtml++noContent :: forall a m. MonadOkapi m => Headers -> m Result+noContent headers = respond 204 headers ""++redirectTo :: forall a m. MonadOkapi m => Char8.ByteString -> m Result+redirectTo url = respond 302 [("Location", url)] ""++-- File Responses++file :: forall m. MonadOkapi m => Natural.Natural -> Headers -> FilePath -> m Result+file status headers filePath = do+  state <- State.get+  logic state+  where+    logic :: State -> m Result+    logic state+      | not $ isMethodParsed state = Except.throwError Skip+      | not $ isPathParsed state = Except.throwError Skip+      | not $ isQueryParamsParsed state = Except.throwError Skip+      -- not $ isBodyParsed request = Except.throwError Skip+      | otherwise = do+        IO.liftIO $ print "Responded from servo, passing off to WAI"+        pure $ ResultFile $ File status headers filePath++okFile :: forall m. MonadOkapi m => Headers -> FilePath -> m Result+okFile headers = file 200 headers++-- Event Source Responses++connectEventSource :: forall m. MonadOkapi m => EventSource.EventSource -> m Result+connectEventSource eventSource = do+  IO.liftIO $ print "Attempting to connect SSE source from Servo"+  state <- State.get+  logic state+  where+    logic :: State -> m Result+    logic state+      | not $ isMethodParsed state = Except.throwError Skip+      | not $ isPathParsed state = Except.throwError Skip+      | not $ isQueryParamsParsed state = Except.throwError Skip+      -- not $ isBodyParsed request = Except.throwError Skip+      | otherwise = do+        IO.liftIO $ print "Responded from servo, passing off to WAI"+        pure $ ResultEventSource eventSource++-- ERROR FUNCTIONS++skip :: forall a m. MonadOkapi m => m a+skip = Except.throwError Skip++error :: forall a m. MonadOkapi m => Natural.Natural -> Headers -> LazyByteString.ByteString -> m a+error status headers = Except.throwError . Error . Response status headers++error500 :: forall a m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m a+error500 = error 500++error401 :: forall a m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m a+error401 = error 401++error403 :: forall a m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m a+error403 = error 403++error404 :: forall a m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m a+error404 = error 404++error422 :: forall a m. MonadOkapi m => Headers -> LazyByteString.ByteString -> m a+error422 = error 422++-- | Execute the next parser even if the first one throws an Error error+(<!>) :: MonadOkapi m => m a -> m a -> m a+parser1 <!> parser2 = Except.catchError parser1 (const parser2)++optionalError :: MonadOkapi m => m a -> m (Maybe a)+optionalError parser = (Just <$> parser) <!> pure Nothing++optionError :: MonadOkapi m => a -> m a -> m a+optionError value parser = do+  mbValue <- optionalError parser+  case mbValue of+    Nothing -> pure value+    Just value' -> pure value'++-- PARSING GUARDS AND SWITCHES++isMethodParsed :: State -> Bool+isMethodParsed State {..} = stateRequestMethodParsed++isPathParsed :: State -> Bool+isPathParsed State {..} = Prelude.null $ requestPath stateRequest++isQueryParamsParsed :: State -> Bool+isQueryParamsParsed State {..} = Prelude.null $ requestQuery stateRequest++isBodyParsed :: State -> Bool+isBodyParsed State {..} = stateRequestBodyParsed++methodMatches :: State -> HTTP.Method -> Bool+methodMatches State {..} method = method == requestMethod stateRequest++segMatches :: State -> (Text.Text -> Bool) -> Bool+segMatches state predicate =+  maybe False predicate $ getSeg state++getPath :: State -> [Text.Text]+getPath State {..} = requestPath stateRequest++getSeg :: State -> Maybe Text.Text+getSeg State {..} = safeHead (requestPath stateRequest)++getQueryItem :: State -> (Text.Text -> Bool) -> Maybe QueryItem+getQueryItem State {..} predicate = Foldable.find (\(key, _) -> predicate key) (requestQuery stateRequest)++getHeader :: State -> HTTP.HeaderName -> Maybe HTTP.Header+getHeader State {..} key = Foldable.find (\(key', _) -> key == key') (requestHeaders stateRequest)++getRequestBody :: State -> IO LazyByteString.ByteString+getRequestBody State {..} = requestBody stateRequest++methodParsed :: State -> State+methodParsed state = state {stateRequestMethodParsed = True}++segParsed :: State -> State+segParsed state = state {stateRequest = (stateRequest state) {requestPath = Prelude.drop 1 $ requestPath $ stateRequest state}}++pathParsed :: State -> State+pathParsed state = state {stateRequest = (stateRequest state) {requestPath = []}}++queryParamParsed :: State -> QueryItem -> State+queryParamParsed state queryItem = state {stateRequest = (stateRequest state) {requestQuery = List.delete queryItem $ requestQuery $ stateRequest state}}++-- TODO: Don't List.delete header??+headerParsed :: State -> HTTP.Header -> State+headerParsed state header = state {stateRequest = (stateRequest state) {requestHeaders = List.delete header $ requestHeaders $ stateRequest state}}++bodyParsed :: State -> State+bodyParsed state = state {stateRequestBodyParsed = True}++-- HELPERS++eitherToMaybe :: Either l r -> Maybe r+eitherToMaybe (Left _) = Nothing+eitherToMaybe (Right x) = Just x++safeHead :: [a] -> Maybe a+safeHead [] = Nothing+safeHead (x : _) = Just x++lookupBy :: forall a b. (a -> Bool) -> [(a, b)] -> Maybe b+lookupBy _ [] = Nothing+lookupBy predicate ((x, y) : xys)+  | predicate x = Just y+  | otherwise = lookupBy predicate xys
+ src/Okapi/Type.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StrictData #-}++module Okapi.Type where++import qualified Control.Applicative as Applicative+import qualified Control.Concurrent.Chan as Chan+-- import qualified Network.Wai.EventSource as EventSource++import qualified Control.Concurrent.STM.TVar as TVar+import qualified Control.Monad as Monad+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.Reader.Class as Reader+import qualified Control.Monad.State.Class as State+import qualified Control.Monad.Trans.Except as ExceptT+import qualified Control.Monad.Trans.State.Strict as StateT+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import qualified Data.Vault.Lazy as Vault+import qualified GHC.Natural as Natural+import qualified Network.HTTP.Types as HTTP+import qualified Okapi.EventSource as EventSource++type Path = [Text.Text]++type Headers = [HTTP.Header]++type QueryItem = (Text.Text, Maybe Text.Text)++type Query = [QueryItem]++data State = State+  { stateRequest :: Request,+    -- , stateEventSourcePoolTVar :: TVar.TVar EventSource.EventSourcePool+    stateRequestMethodParsed :: Bool,+    stateRequestBodyParsed :: Bool+    -- , stateResulted :: Bool+  }++data Request = Request+  { requestMethod :: HTTP.Method,+    requestPath :: Path,+    requestQuery :: Query,+    requestBody :: IO LazyByteString.ByteString,+    requestHeaders :: Headers,+    requestVault :: Vault.Vault+  }++data Result+  = ResultResponse Response+  | ResultFile File+  | ResultEventSource EventSource.EventSource++-- ResultJob (IO ())++data File = File+  { fileStatus :: Natural.Natural+  , fileHeaders :: Headers+  , filePath :: FilePath+  }++data Response = Response+  { responseStatus :: Natural.Natural,+    responseHeaders :: Headers,+    responseBody :: LazyByteString.ByteString+  }++-- TODO: ADD Text field to skip fo +data Failure = Skip | Error Response++newtype OkapiT m a = OkapiT {unOkapiT :: ExceptT.ExceptT Failure (StateT.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 f okapiT =+    OkapiT . ExceptT.ExceptT . StateT.StateT $+      ( fmap (\ ~(a, s') -> (f <$> a, s'))+          . StateT.runStateT (ExceptT.runExceptT $ unOkapiT okapiT)+      )+  {-# INLINE fmap #-}++instance Monad m => Applicative (OkapiT m) where+  pure x = OkapiT . ExceptT.ExceptT . StateT.StateT $ \s -> pure (Right x, s)+  {-# INLINEABLE pure #-}+  (OkapiT (ExceptT.ExceptT (StateT.StateT mf))) <*> (OkapiT (ExceptT.ExceptT (StateT.StateT mx))) = OkapiT . ExceptT.ExceptT . StateT.StateT $ \s -> do+    ~(eitherF, s') <- mf s+    case eitherF of+      Left error -> pure (Left error, s)+      Right f -> do+        ~(eitherX, s'') <- mx s'+        case eitherX of+          Left error' -> pure (Left error', s')+          Right x -> pure (Right $ f x, s'')+  {-# INLINEABLE (<*>) #-}+  m *> k = m >> k+  {-# INLINE (*>) #-}++instance Monad m => Applicative.Alternative (OkapiT m) where+  empty = OkapiT . ExceptT.ExceptT . StateT.StateT $ \s -> pure (Left Skip, s)+  {-# INLINE empty #-}+  (OkapiT (ExceptT.ExceptT (StateT.StateT mx))) <|> (OkapiT (ExceptT.ExceptT (StateT.StateT my))) = OkapiT . ExceptT.ExceptT . StateT.StateT $ \s -> do+    (eitherX, stateX) <- mx s+    case eitherX of+      Left Skip -> do+        (eitherY, stateY) <- my s+        case eitherY of+          Left Skip -> pure (Left Skip, s)+          Left error@(Error _) -> pure (Left error, s)+          Right y -> pure (Right y, stateY)+      Left error@(Error _) -> pure (Left error, s)+      Right x -> pure (Right x, stateX)+  {-# INLINEABLE (<|>) #-}++instance Monad m => Monad (OkapiT m) where+  return = pure+  {-# INLINEABLE return #-}+  (OkapiT (ExceptT.ExceptT (StateT.StateT mx))) >>= f = OkapiT . ExceptT.ExceptT . StateT.StateT $ \s -> do+    ~(eitherX, s') <- mx s+    case eitherX of+      Left error -> pure (Left error, s)+      Right x -> do+        ~(eitherResult, s'') <- StateT.runStateT (ExceptT.runExceptT $ unOkapiT $ f x) s'+        case eitherResult of+          Left error' -> pure (Left error', s')+          Right res -> pure (Right res, s'')+  {-# INLINEABLE (>>=) #-}++instance Monad m => Monad.MonadPlus (OkapiT m) where+  mzero = OkapiT . ExceptT.ExceptT . StateT.StateT $ \s -> pure (Left Skip, s)+  {-# INLINE mzero #-}+  (OkapiT (ExceptT.ExceptT (StateT.StateT mx))) `mplus` (OkapiT (ExceptT.ExceptT (StateT.StateT my))) = OkapiT . ExceptT.ExceptT . StateT.StateT $ \s -> do+    (eitherX, stateX) <- mx s+    case eitherX of+      Left Skip -> do+        (eitherY, stateY) <- my s+        case eitherY of+          Left Skip -> pure (Left Skip, s)+          Left error@(Error _) -> pure (Left error, s)+          Right y -> pure (Right y, stateY)+      Left error@(Error _) -> pure (Left error, s)+      Right x -> pure (Right x, stateX)+  {-# INLINEABLE mplus #-}++instance IO.MonadIO m => IO.MonadIO (OkapiT m) where+  liftIO = Morph.lift . IO.liftIO++instance Reader.MonadReader r m => Reader.MonadReader r (OkapiT m) where+  ask = Morph.lift Reader.ask+  local = mapOkapiT . Reader.local+    where+      mapOkapiT :: (m (Either Failure a, State) -> n (Either Failure b, State)) -> OkapiT m a -> OkapiT n b+      mapOkapiT f okapiT = OkapiT . ExceptT.ExceptT . StateT.StateT $ f . StateT.runStateT (ExceptT.runExceptT $ unOkapiT okapiT)+  reader = Morph.lift . Reader.reader++-- instance State.MonadState s m => State.MonadState s (OkapiT m) where+--   get = Morph.lift State.get+--   put = Morph.lift . State.put++instance Morph.MonadTrans OkapiT where+  lift :: Monad m => m a -> OkapiT m a+  lift action = OkapiT . ExceptT.ExceptT . StateT.StateT $ \s -> do+    result <- action+    pure (Right result, s)++instance Morph.MFunctor OkapiT where+  hoist :: Monad m => (forall a. m a -> n a) -> OkapiT m b -> OkapiT n b+  hoist nat okapiT = OkapiT . ExceptT.ExceptT . StateT.StateT $ (nat . StateT.runStateT (ExceptT.runExceptT $ unOkapiT okapiT))++type MonadOkapi m =+  ( Functor m,+    Applicative m,+    Applicative.Alternative m,+    Monad m,+    Monad.MonadPlus m,+    IO.MonadIO m,+    Except.MonadError Failure m,+    State.MonadState State m+  )
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"