tonatona-servant (empty) → 0.1.0.0
raw patch · 7 files changed
+314/−0 lines, 7 filesdep +Globdep +basedep +doctestsetup-changed
Dependencies added: Glob, base, doctest, exceptions, http-types, monad-logger, rio, servant, servant-server, tonaparser, tonatona, tonatona-logger, wai, wai-extra, warp
Files
- LICENSE +21/−0
- README.md +3/−0
- Setup.hs +2/−0
- src/Tonatona/Servant.hs +123/−0
- test/DocTest.hs +58/−0
- test/Spec.hs +8/−0
- tonatona-servant.cabal +99/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2018 Kadzuya Okamoto https://arow.info++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.
+ README.md view
@@ -0,0 +1,3 @@+# tonatona-servant++A plugin for `tonatona` that adds the ability to run a Servant application.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Tonatona/Servant.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}++module Tonatona.Servant+ ( Tonatona.Servant.run+ , redirect+ , Config(..)+ , Host(..)+ , Port+ , Protocol(..)+ ) where++import RIO++import Network.HTTP.Types.Header+import Network.Wai (Middleware)+import Network.Wai.Handler.Warp (Port)+import qualified Network.Wai.Handler.Warp as Warp+import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)+import Servant++import TonaParser (Parser, (.||), argLong, envVar, optionalVal)+import Tonatona (HasConfig(..), HasParser(..))+import qualified Tonatona.Logger as TonaLogger++{-| Main function.+ -}+run ::+ forall (api :: *) env.+ (HasServer api '[], HasConfig env Config, HasConfig env TonaLogger.Config)+ => ServerT api (RIO env)+ -> RIO env ()+run servantServer = do+ env <- ask+ conf <- asks config+ loggingMiddleware <- reqLogMiddleware+ let app = runServant @api env servantServer+ liftIO $ Warp.run (port conf) $ loggingMiddleware app++runServant ::+ forall (api :: *) env. (HasServer api '[])+ => env+ -> ServerT api (RIO env)+ -> Application+runServant env servantServer =+ serve (Proxy @api) $ hoistServer (Proxy @api) transformation servantServer+ where+ transformation+ :: forall a. RIO env a -> Servant.Handler a+ transformation action = do+ let+ ioAction = Right <$> runRIO env action+ eitherRes <- liftIO $ ioAction `catch` \(e :: ServantErr) -> pure $ Left e+ case eitherRes of+ Right res -> pure res+ Left servantErr -> throwError servantErr++redirect :: ByteString -> RIO env a+redirect redirectLocation =+ throwM $+ err302+ { errHeaders = [(hLocation, redirectLocation)]+ }++reqLogMiddleware :: (HasConfig env TonaLogger.Config) => RIO env Middleware+reqLogMiddleware = do+ TonaLogger.Config {mode, verbose} <- asks config+ pure $+ if TonaLogger.defaultVerbosity mode verbose+ then logStdoutDev+ else logStdout++-- Config++-- | This defines the host part of a URL.+--+-- For example, in the URL https://some.url.com:8090/, the host is+-- @some.url.com@.+newtype Host = Host+ { unHost :: Text+ } deriving (Eq, IsString, Read, Show)++-- | This defines the protocol part of a URL.+--+-- For example, in the URL https://some.url.com:8090/, the protocol is+-- @https@.+newtype Protocol = Protocol+ { unProtocol :: Text+ } deriving (Eq, IsString, Read, Show)++data Config = Config+ { host :: Host+ , protocol :: Protocol+ , port :: Port+ }+ deriving (Show)++instance HasParser Host where+ parser = Host <$>+ optionalVal+ "Host name to serve"+ (argLong "host" .|| envVar "HOST")+ "localhost"++instance HasParser Protocol where+ parser = Protocol <$>+ optionalVal+ "Protocol to serve"+ (argLong "protocol" .|| envVar "PROTOCOL")+ "http"++portParser :: Parser Port+portParser =+ optionalVal+ "Port to serve"+ (argLong "port" .|| envVar "PORT")+ 8000++instance HasParser Config where+ parser = Config+ <$> parser+ <*> parser+ <*> portParser
+ test/DocTest.hs view
@@ -0,0 +1,58 @@+module Main (main) where++import RIO++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = glob "src/**/*.hs" >>= doDocTest++doDocTest :: [String] -> IO ()+doDocTest options =+ doctest $+ options <>+ ghcExtensions++ghcExtensions :: [String]+ghcExtensions =+ [ "-XAutoDeriveTypeable"+ , "-XBangPatterns"+ , "-XBinaryLiterals"+ , "-XConstraintKinds"+ , "-XDataKinds"+ , "-XDefaultSignatures"+ , "-XDeriveDataTypeable"+ , "-XDeriveFoldable"+ , "-XDeriveFunctor"+ , "-XDeriveGeneric"+ , "-XDeriveTraversable"+ , "-XDoAndIfThenElse"+ , "-XEmptyDataDecls"+ , "-XExistentialQuantification"+ , "-XFlexibleContexts"+ , "-XFlexibleInstances"+ , "-XFunctionalDependencies"+ , "-XGADTs"+ , "-XGeneralizedNewtypeDeriving"+ , "-XInstanceSigs"+ , "-XKindSignatures"+ , "-XLambdaCase"+ , "-XMonadFailDesugaring"+ , "-XMultiParamTypeClasses"+ , "-XMultiWayIf"+ , "-XNamedFieldPuns"+ , "-XNoImplicitPrelude"+ , "-XOverloadedStrings"+ , "-XPartialTypeSignatures"+ , "-XPatternGuards"+ , "-XPolyKinds"+ , "-XRankNTypes"+ , "-XRecordWildCards"+ , "-XScopedTypeVariables"+ , "-XStandaloneDeriving"+ , "-XTupleSections"+ , "-XTypeFamilies"+ , "-XTypeSynonymInstances"+ , "-XViewPatterns"+ ]
+ test/Spec.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE QuasiQuotes #-}++module Main where++import RIO++main :: IO ()+main = pure ()
+ tonatona-servant.cabal view
@@ -0,0 +1,99 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: c42b18ee3b816d6e22ace370e595c459acc1a96325b18b724f7922ab89a5fc67++name: tonatona-servant+version: 0.1.0.0+synopsis: tonatona plugin for servant.+description: Tonatona plugin for @servant@. This package provides a tonatona plugin for @servant@.+category: Library, Tonatona, Servant, Web+homepage: https://github.com/tonatona-project/tonatona#readme+bug-reports: https://github.com/tonatona-project/tonatona/issues+author: Kadzuya Okamoto, Dennis Gosnell+maintainer: arow.okamoto+github@gmail.com+copyright: 2018 Kadzuya Okamoto+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/tonatona-project/tonatona++library+ exposed-modules:+ Tonatona.Servant+ other-modules:+ Paths_tonatona_servant+ hs-source-dirs:+ src+ default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving Strict StrictData TupleSections TypeFamilies TypeSynonymInstances ViewPatterns+ ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , exceptions >=0.8+ , http-types >=0.12+ , monad-logger >=0.3+ , rio >=0.1+ , servant >=0.13+ , servant-server >=0.13+ , tonaparser >=0.1+ , tonatona >=0.1+ , tonatona-logger >=0.1+ , wai >=3.2+ , wai-extra >=3.0+ , warp >=3.2+ default-language: Haskell2010++test-suite doctest+ type: exitcode-stdio-1.0+ main-is: DocTest.hs+ hs-source-dirs:+ test+ default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving Strict StrictData TupleSections TypeFamilies TypeSynonymInstances ViewPatterns+ ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ build-depends:+ Glob+ , base >=4.7 && <5+ , doctest+ , exceptions >=0.8+ , http-types >=0.12+ , monad-logger >=0.3+ , rio >=0.1+ , servant >=0.13+ , servant-server >=0.13+ , tonaparser >=0.1+ , tonatona >=0.1+ , tonatona-logger >=0.1+ , wai >=3.2+ , wai-extra >=3.0+ , warp >=3.2+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving Strict StrictData TupleSections TypeFamilies TypeSynonymInstances ViewPatterns+ ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , exceptions >=0.8+ , http-types >=0.12+ , monad-logger >=0.3+ , rio >=0.1+ , servant >=0.13+ , servant-server >=0.13+ , tonaparser >=0.1+ , tonatona+ , tonatona-logger >=0.1+ , wai >=3.2+ , wai-extra >=3.0+ , warp >=3.2+ default-language: Haskell2010