packages feed

trasa-server (empty) → 0.1

raw patch · 5 files changed

+335/−0 lines, 5 filesdep +basedep +bytestringdep +case-insensitivesetup-changed

Dependencies added: base, bytestring, case-insensitive, containers, doctest, http-client, http-types, mtl, tasty, tasty-hunit, tasty-quickcheck, text, trasa, trasa-server, vinyl, wai, warp

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Andrew Martin (c) 2017++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 Andrew Martin 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Trasa/Server.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-# OPTIONS_GHC -Wall -Werror #-}+module Trasa.Server+  ( TrasaT+  , runTrasaT+  , serveWith+  ) where++import Control.Monad (join)+import Data.Traversable (for)+import Data.Functor.Identity++import Network.HTTP.Types.Header (hAccept,hContentType)+import qualified Network.HTTP.Types.Status as S+import Data.CaseInsensitive (CI)+import qualified Network.Wai as WAI+import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Map.Strict as M+import Control.Monad.Reader (ReaderT,runReaderT,MonadReader(..),MonadTrans(..))+import Control.Monad.Except (ExceptT,runExceptT,MonadError(..),MonadIO(..))+import Control.Monad.State.Strict (StateT,runStateT,MonadState(..))++import Trasa.Core++type Headers = M.Map (CI BS.ByteString) T.Text++newtype TrasaT m a = TrasaT+  { unTrasaT :: ExceptT TrasaErr (StateT Headers (ReaderT Headers m)) a+  } deriving+  ( Functor+  , Applicative+  , Monad+  , MonadError TrasaErr+  , MonadIO+  , MonadState (M.Map (CI BS.ByteString) T.Text)+  , MonadReader (M.Map (CI BS.ByteString) T.Text))++instance MonadTrans TrasaT where+  lift = TrasaT . lift . lift . lift++runTrasaT+  :: TrasaT m a+  -> M.Map (CI BS.ByteString) T.Text -- ^ Headers+  -> m (Either TrasaErr a, M.Map (CI BS.ByteString) T.Text)+runTrasaT trasa headers = (flip runReaderT headers . flip runStateT M.empty . runExceptT  . unTrasaT) trasa++serveWith+  :: (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureDecoding) qrys)+  -- ^ How to decode the query parameters from a route+  -> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyDecoding) req)+  -- ^ How to decode the request body from a route+  -> (forall caps qrys req resp. route caps qrys req resp -> ResponseBody (Many BodyEncoding) resp)+  -- ^ How to encode the response body from a route+  -> (forall caps qrys req resp.+         route caps qrys req resp+      -> Rec Identity caps+      -> Rec Parameter qrys+      -> RequestBody Identity req+      -> TrasaT IO resp)+  -- ^ Actions to perform when requests come in+  -> Router route -- ^ Router+  -> WAI.Application -- ^ WAI Application+serveWith toQuerys toReqBody toRespBody makeResponse router =+  \req respond ->+    case TE.decodeUtf8' (WAI.requestMethod req) of+      Left _ -> respond (WAI.responseLBS S.status400 [] "Non utf8 encoded request method")+      Right method -> case parseHeaders req of+        Left _ -> respond (WAI.responseLBS S.status400 [] "Non utf8 encoded headers")+        Right headers -> case parseAccepts headers of+          Nothing -> respond (WAI.responseLBS S.status415 [] "Accept header missing")+          Just accepts -> do+            content <- for (M.lookup hContentType headers) $ \typ ->+              Content typ <$> WAI.strictRequestBody req+            let url = Url (WAI.pathInfo req) (decodeQuery (WAI.queryString req))+                dispatch = dispatchWith toQuerys toReqBody toRespBody makeResponse router method accepts url content+            runTrasaT dispatch headers >>= \case+              (resErr,newHeaders) -> case join resErr of+                Left (TrasaErr stat errBody) ->+                  respond (WAI.responseLBS stat (encodeHeaders newHeaders) errBody)+                Right (Content typ lbs) -> do+                  let encodedHeaders = encodeHeaders (M.insert hContentType typ newHeaders)+                  respond (WAI.responseLBS S.status200 encodedHeaders lbs)+  where+    encodeHeaders = M.toList . fmap TE.encodeUtf8+    parseHeaders = traverse TE.decodeUtf8' . M.fromList . WAI.requestHeaders+    parseAccepts = fmap (fmap T.strip . T.splitOn (T.singleton ',')) . M.lookup hAccept
+ test/Main.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}++import Trasa.Core+import Trasa.Server+import Data.Vinyl+import Data.Functor.Identity+import Data.Kind (Type)+import Text.Read (readMaybe)+import Network.Wai.Handler.Warp (withApplication)+import qualified Data.Text as T+import qualified Data.ByteString.Lazy.Char8 as LBSC+import qualified Network.HTTP.Client as HC++main :: IO ()+main = do+  putStrLn "\nStarting trasa server test suite"+  let app = serveWith+        (mapQuery captureCodecToCaptureDecoding . metaQuery . meta)+        (mapRequestBody (Many . pure . bodyCodecToBodyDecoding) . metaRequestBody . meta)+        (mapResponseBody (Many . pure . bodyCodecToBodyEncoding) . metaResponseBody . meta)+        handle+        router+  withApplication (return app) $ \port -> do+    manager <- HC.newManager HC.defaultManagerSettings+    attempt manager ("GET http://127.0.0.1:" ++ show port ++ "/") $ \x -> x+      { HC.requestHeaders = [("Accept","text/plain"),("ContentType","text/plain")]+      }+    attempt manager ("GET http://127.0.0.1:" ++ show port ++ "/hello") $ \x -> x+      { HC.requestHeaders = [("Accept","text/plain"),("ContentType","text/plain")]+      }+    return ()++attempt :: HC.Manager -> String -> (HC.Request -> HC.Request) -> IO ()+attempt mngr url modify = do+  req <- HC.parseUrlThrow url+  let req' = modify req+  _ <- HC.httpLbs req' mngr+  return ()++handle :: Route caps qrys req resp -> Rec Identity caps -> Rec Parameter qrys -> RequestBody Identity req -> TrasaT IO resp+handle r = case r of+  EmptyR -> \_ _ _ -> return (55 :: Int)+  HelloR -> \_ _ _ -> return (67 :: Int)++data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where+  EmptyR :: Route '[] '[] Bodyless Int+  HelloR :: Route '[] '[] Bodyless Int+  AdditionR :: Route '[Int,Int] '[Optional Int] Bodyless Int+  IdentityR :: Route '[String] '[] Bodyless String+  LeftPadR :: Route '[Int] '[] (Body String) String+  TrickyOneR :: Route '[Int] '[] Bodyless String+  TrickyTwoR :: Route '[Int,Int] '[] Bodyless String+++prepare :: Route cs qs rq rp -> Arguments cs qs rq (Prepared Route rp)+prepare = prepareWith (metaPath . meta) (metaQuery . meta) (metaRequestBody . meta)++link :: Prepared Route rp -> Url+link = linkWith+  (mapPath (CaptureEncoding . captureCodecEncode) . metaPath . meta)+  (mapQuery captureCodecToCaptureEncoding . metaQuery . meta)++parse :: T.Text -> Maybe Content -> Either TrasaErr (Concealed Route)+parse url = parseWith+  (mapQuery captureCodecToCaptureDecoding . metaQuery . meta)+  (mapRequestBody (Many . pure . bodyCodecToBodyDecoding) . metaRequestBody . meta)+  router+  "GET"+  (decodeUrl url)++allRoutes :: [Constructed Route]+allRoutes = +  [ Constructed HelloR+  , Constructed AdditionR+  , Constructed IdentityR+  , Constructed LeftPadR+  , Constructed TrickyOneR+  , Constructed TrickyTwoR+  , Constructed EmptyR+  ]++router :: Router Route+router = routerWith+  (metaMethod . meta)+  (mapPath (CaptureDecoding . captureCodecDecode) . metaPath . meta)+  allRoutes++data Meta ps qs rq rp = Meta+  { metaPath :: Path CaptureCodec ps+  , metaQuery :: Rec (Query CaptureCodec) qs+  , metaRequestBody :: RequestBody BodyCodec rq+  , metaResponseBody :: ResponseBody BodyCodec rp+  , metaMethod :: T.Text+  }++meta :: Route ps qs rq rp -> Meta ps qs rq rp+meta x = case x of+  EmptyR -> Meta+    end+    qend+    bodyless (resp bodyInt) "GET"+  HelloR -> Meta+    (match "hello" ./ end)+    qend+    bodyless (resp bodyInt) "GET"+  AdditionR -> Meta+    (match "add" ./ capture int ./ capture int ./ end)+    (optional "more" int .& qend)+    bodyless (resp bodyInt) "GET"+  IdentityR -> Meta+    (match "identity" ./ capture string ./ end)+    qend+    bodyless (resp bodyString) "GET"+  LeftPadR -> Meta+    (match "pad" ./ match "left" ./ capture int ./ end)+    qend+    (body bodyString) (resp bodyString) "GET"+  TrickyOneR -> Meta+    (match "tricky" ./ capture int ./ match "one" ./ end)+    qend+    bodyless (resp bodyString) "GET"+  TrickyTwoR -> Meta+    (capture int ./ capture int ./ match "two" ./ end)+    qend+    bodyless (resp bodyString) "GET"+++int :: CaptureCodec Int+int = CaptureCodec (T.pack . show) (readMaybe . T.unpack)++string :: CaptureCodec String+string = CaptureCodec T.pack (Just . T.unpack)++bodyString :: BodyCodec String+bodyString = BodyCodec (pure "text/plain") LBSC.pack (Right . LBSC.unpack)++bodyUnit :: BodyCodec ()+bodyUnit = BodyCodec (pure "text/plain") (const "") (const (Right ()))++note :: e -> Maybe a -> Either e a+note e Nothing = Left e+note _ (Just x) = Right x++bodyInt :: BodyCodec Int+bodyInt = BodyCodec (pure "text/plain") (LBSC.pack . show)+                    (note "Could not decode int" . readMaybe . LBSC.unpack)
+ trasa-server.cabal view
@@ -0,0 +1,52 @@+name: trasa-server+version: 0.1+synopsis: Type safe web server+homepage: https://github.com/haskell-trasa/trasa#readme+license: BSD3+license-file: LICENSE+author: Kyle McKean+maintainer: mckean.kylej@gmail.com+copyright: 2017 Kyle McKean+category: Web+build-type: Simple+cabal-version: >=1.10+description: WAI integration for trasa++library+  hs-source-dirs: src+  exposed-modules:+    Trasa.Server+  build-depends:+      base >= 4.7 && < 5+    , bytestring == 0.10.*+    , text == 1.2.*+    , wai == 3.2.*+    , http-types == 0.9.*+    , case-insensitive == 1.2.*+    , containers == 0.5.*+    , mtl == 2.2.*+    , trasa+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends: +      base+    , trasa+    , trasa-server+    , tasty+    , tasty-quickcheck+    , tasty-hunit+    , bytestring+    , text+    , vinyl+    , doctest+    , warp+    , http-client+  default-language: Haskell2010++source-repository head+  type:     git+  location: https://github.com/haskell-trasa/trasa