jordan-servant-server (empty) → 0.1.0.0

raw patch · 5 files changed

+192/−0 lines, 5 filesdep +attoparsecdep +basedep +bytestring

Dependencies added: attoparsec, base, bytestring, generics-sop, http-media, http-types, jordan, jordan-servant, servant, servant-server, text, transformers, wai

Files

• CHANGELOG.md +5/−0
• LICENSE +20/−0
• jordan-servant-server.cabal +60/−0
• lib/Jordan/Servant/Server.hs +103/−0
• test/MyLibTest.hs +4/−0

@@ -0,0 +1,5 @@+# Revision history for jordan-servant-server++## 0.1.0.0 -- 2022-07-04++* First version. Contains orphans for everything in the `jordan-servant` package.

@@ -0,0 +1,20 @@+Copyright (c) 2022 Anthony Super++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,60 @@+cabal-version:      2.4+name:               jordan-servant-server+version:            0.1.0.0+synopsis:           Servers for Jordan-Based Servant Combinators++-- A longer description of the package.+description:+  Server-Side Orphan Instances for Jordan-Servant.+  Allows you to use the API combinators provided in that package to write servers.++homepage:           https://github.com/AnthonySuper/jordan++-- A URL where users can report bugs.+-- bug-reports:+license:            MIT+license-file:       LICENSE+author:             Anthony Super+maintainer:         anthony@noided.media++-- A copyright notice.+-- copyright:+category:           Web+extra-source-files: CHANGELOG.md++common build-deps+  build-depends:+    , attoparsec >= 0.14.1 && <0.15+    , bytestring >= 0.10.8.1 && <0.12+    , jordan >= 0.2.0.0 && <0.3+    , jordan-servant >= 0.1.0.0 && <0.2+    , servant >= 0.18 && <0.20+    , text >= 1.2.3.0 && <1.3+    , servant-server >= 0.19 && <0.20+    , http-types >= 0.12.2 && <0.13+    , http-media >= 0.7 && <0.9+    , transformers >=0.5.5 && <= 0.7+    , wai >= 3.2 && <= 3.3+    , generics-sop >=0.5 && <=0.6+    , base >= 4.14.1 && <4.17++library+    import: build-deps+    exposed-modules:+        Jordan.Servant.Server+++    -- Modules included in this library but not exported.+    -- other-modules:++    -- LANGUAGE extensions used by modules in this package.+    -- other-extensions:+    hs-source-dirs:   lib+    default-language: Haskell2010++test-suite jordan-servant-server-test+    import: build-deps+    default-language: Haskell2010+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          MyLibTest.hs

@@ -0,0 +1,103 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Provides instances from server-related types to jordan API combinators.+--+-- Sadly, this does mean that this module has a bunch of orphan instances.+-- Please, *please* use these instead of any others.+-- Please.+module Jordan.Servant.Server where++import Control.Monad.IO.Class+import Data.ByteString as SBS+import qualified Data.ByteString.Lazy as LBS+import Data.List.NonEmpty (toList)+import Data.Maybe (fromMaybe)+import Data.Proxy+import qualified Data.Text as T+import GHC.TypeLits+import Jordan+import Jordan.Servant+import Jordan.Servant.Query+import Jordan.Servant.Query.Parse+import Jordan.Types.JSONError+import Network.HTTP.Media (matchContent)+import Network.HTTP.Types.Header (hContentType)+import Network.Wai (Request (..), lazyRequestBody, queryString)+import Servant.API+import Servant.API.Modifiers+import Servant.Server+import Servant.Server.Internal+import Servant.Server.Internal.ServerError+import Servant.Server.UVerb++-- | Parse a request body.+-- On parse errors where a valid but wrong-for-the-type JSON is given, we return back an error report.+instance forall a rest context. (HasServer rest context, FromJSON a) => HasServer (ReportingRequestBody a :> rest) context where+  type ServerT (ReportingRequestBody a :> rest) m = a -> ServerT rest m+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy rest) pc nt . s+  route (Proxy :: Proxy (ReportingRequestBody a :> rest)) context subserver =+    route (Proxy :: Proxy rest) context $ addBodyCheck subserver checkContent checkBody+    where+      checkContent = withRequest $ \request -> do+        let contentType = fromMaybe "application/octect-stream" $ lookup hContentType $ requestHeaders request+        case matchContent (toList $ contentTypes (Proxy :: Proxy JordanJSON)) contentType of+          Nothing -> delayedFail err415+          Just _ -> pure (parseOrReport @a)+      checkBody parser = withRequest $ \request -> do+        body <- liftIO $ lazyRequestBody request+        case parser (LBS.toStrict body) of+          Left je ->+            delayedFailFatal $+              ServerError+                { errHTTPCode = 400,+                  errReasonPhrase = "Bad Request",+                  errBody = toJSONViaBuilder je,+                  errHeaders = [("Content-Type", "application/json+haskell-servant-body-error")]+                }+          Right a -> pure a++-- | If the query was required, no maybe.+-- Otherwise, wrap the query in a maybe.+type QueryArgument mods a = If (FoldRequired mods) a (Maybe a)++instance+  forall a rest context baseKey mods.+  ( HasServer rest context,+    FromJSON a,+    KnownSymbol baseKey,+    SBoolI (FoldRequired mods)+  ) =>+  HasServer (JordanQuery' baseKey mods a :> rest) context+  where+  type ServerT (JordanQuery' baseKey mods a :> rest) m = QueryArgument mods a -> ServerT rest m+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy rest) pc nt . s+  route (Proxy :: Proxy (JordanQuery' baseKey mods a :> rest)) context subserver =+    route (Proxy :: Proxy rest) context $ subserver `addParameterCheck` withRequest paramsCheck+    where+      keyName = T.pack $ symbolVal (Proxy :: Proxy baseKey)+      parseQ :: Request -> Either String a+      parseQ = parseQueryAtKey keyName . queryString+      hasQuery = hasQueryAtKey keyName . queryString+      failWithError s =+        delayedFailFatal $+          err400+            { errBody = toJSONViaBuilder s,+              errHeaders = [("Content-Type", "application/json+haskell-jordan-query-error")]+            }+      paramsCheck req =+        let parsed = parseQ req+            hasKeys = hasQuery req+         in case sbool @(FoldRequired mods) of+              STrue -> either failWithError pure parsed+              SFalse+                | not hasKeys -> pure Nothing+                | otherwise -> either failWithError (pure . Just) parsed

@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."