From 29632c4ac23ad0e630ab2321553695247d883973 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Thu, 23 Apr 2015 13:07:52 +0200 Subject: [PATCH 1/5] add an example on how to derive client functions for Hackage --- servant-examples/LICENSE | 30 +++++++++ servant-examples/Setup.hs | 2 + servant-examples/hackage/hackage.hs | 83 +++++++++++++++++++++++++ servant-examples/servant-examples.cabal | 29 +++++++++ 4 files changed, 144 insertions(+) create mode 100644 servant-examples/LICENSE create mode 100644 servant-examples/Setup.hs create mode 100644 servant-examples/hackage/hackage.hs create mode 100644 servant-examples/servant-examples.cabal diff --git a/servant-examples/LICENSE b/servant-examples/LICENSE new file mode 100644 index 00000000..f2e47b91 --- /dev/null +++ b/servant-examples/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Alp Mestanogullari + +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 Alp Mestanogullari 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. diff --git a/servant-examples/Setup.hs b/servant-examples/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-examples/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-examples/hackage/hackage.hs b/servant-examples/hackage/hackage.hs new file mode 100644 index 00000000..4f49ead3 --- /dev/null +++ b/servant-examples/hackage/hackage.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Monoid +import Data.Proxy +import Data.Text (Text) +import GHC.Generics +import Servant.API +import Servant.Client + +import qualified Data.Text as T +import qualified Data.Text.IO as T + +type HackageAPI = + "users" :> Get '[JSON] [UserSummary] + :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed + :<|> "packages" :> Get '[JSON] [Package] + +type Username = Text + +data UserSummary = UserSummary + { summaryUsername :: Username + , summaryUserid :: Int + } deriving (Eq, Show) + +instance FromJSON UserSummary where + parseJSON (Object o) = + UserSummary <$> o .: "username" + <*> o .: "userid" + + parseJSON _ = mzero + +type Group = Text + +data UserDetailed = UserDetailed + { username :: Username + , userid :: Int + , groups :: [Group] + } deriving (Eq, Show, Generic) + +instance FromJSON UserDetailed + +newtype Package = Package { packageName :: Text } + deriving (Eq, Show, Generic) + +instance FromJSON Package + +hackageAPI :: Proxy HackageAPI +hackageAPI = Proxy + +getUsers :: BaseUrl -> EitherT ServantError IO [UserSummary] +getUser :: Username -> BaseUrl -> EitherT ServantError IO UserDetailed +getPackages :: BaseUrl -> EitherT ServantError IO [Package] +getUsers :<|> getUser :<|> getPackages = client hackageAPI + +run :: (BaseUrl -> r) -> r +run f = f (BaseUrl Http "hackage.haskell.org" 80) + +main :: IO () +main = print =<< uselessNumbers + +uselessNumbers :: IO (Either ServantError ()) +uselessNumbers = runEitherT $ do + users <- run getUsers + liftIO . putStrLn $ show (length users) ++ " users" + + user <- liftIO $ do + putStrLn "Enter a valid hackage username" + T.getLine + userDetailed <- run (getUser user) + liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages" + + packages <- run getPackages + let monadPackages = filter (isMonadPackage . packageName) packages + liftIO . putStrLn $ show (length monadPackages) ++ " monad packages" + + where isMonadPackage = T.isInfixOf "monad" diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal new file mode 100644 index 00000000..3c63b278 --- /dev/null +++ b/servant-examples/servant-examples.cabal @@ -0,0 +1,29 @@ +name: servant-examples +version: 0.3 +synopsis: Example programs for servant +description: Example programs for servant +homepage: http://haskell-servant.github.io/ +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari +maintainer: alpmestan@gmail.com +-- copyright: +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +executable hackage + main-is: hackage.hs + -- other-modules: + -- other-extensions: + build-depends: + aeson >= 0.8 + , base >=4.7 + , either + , servant + , servant-client + , text + , transformers + hs-source-dirs: hackage + default-language: Haskell2010 From 50a1c86f5fb2f2751d67bbe66ae7966f48d539d3 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Thu, 23 Apr 2015 16:31:08 +0200 Subject: [PATCH 2/5] add servant-examples to sources.txt and scripts/shell.nix --- scripts/shell.nix | 12 +++++++----- sources.txt | 1 + 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/scripts/shell.nix b/scripts/shell.nix index ba9e0cb9..5d77034a 100644 --- a/scripts/shell.nix +++ b/scripts/shell.nix @@ -5,16 +5,18 @@ let modifiedHaskellPackages = haskellngPackages.override { overrides = with haskell-ng.lib ; self: super: { servant = appendConfigureFlag ( self.callPackage ../servant {} ) "--ghc-options=-Werror"; - servant-server = appendConfigureFlag (self.callPackage + servant-server = appendConfigureFlag (self.callPackage ../servant-server {}) "--ghc-options=-Werror"; - servant-client = appendConfigureFlag (self.callPackage + servant-client = appendConfigureFlag (self.callPackage ../servant-client {}) "--ghc-options=-Werror"; - servant-jquery = appendConfigureFlag (self.callPackage + servant-jquery = appendConfigureFlag (self.callPackage ../servant-jquery {}) "--ghc-options=-Werror"; - servant-docs = appendConfigureFlag (self.callPackage ../servant-docs + servant-docs = appendConfigureFlag (self.callPackage ../servant-docs + {}) "--ghc-options=-Werror"; + servant-examples = appendConfigureFlag (self.callPackage ../servant-examples {}) "--ghc-options=-Werror"; }; }; in modifiedHaskellPackages.ghcWithPackages ( p : with p ; [ - servant servant-server servant-client servant-jquery servant-docs + servant servant-server servant-client servant-jquery servant-docs servant-examples ]) diff --git a/sources.txt b/sources.txt index 88cd15da..d12c1275 100644 --- a/sources.txt +++ b/sources.txt @@ -3,3 +3,4 @@ servant-client servant-docs servant-jquery servant-server +servant-examples From ac73b825f06e44663d57a848a2aa6d58095c616c Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Thu, 23 Apr 2015 17:10:43 +0200 Subject: [PATCH 3/5] fix tab warning --- servant-examples/hackage/hackage.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-examples/hackage/hackage.hs b/servant-examples/hackage/hackage.hs index 4f49ead3..4df8052b 100644 --- a/servant-examples/hackage/hackage.hs +++ b/servant-examples/hackage/hackage.hs @@ -18,7 +18,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T type HackageAPI = - "users" :> Get '[JSON] [UserSummary] + "users" :> Get '[JSON] [UserSummary] :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed :<|> "packages" :> Get '[JSON] [Package] From e371fb886f8fdf1599b0eb23765c575a365e2520 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Fri, 24 Apr 2015 12:37:33 +0200 Subject: [PATCH 4/5] add an example to show how to apply a WAI middleware --- servant-examples/servant-examples.cabal | 14 +++++ .../wai-middleware/wai-middleware.hs | 51 +++++++++++++++++++ 2 files changed, 65 insertions(+) create mode 100644 servant-examples/wai-middleware/wai-middleware.hs diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index 3c63b278..65a92b98 100644 --- a/servant-examples/servant-examples.cabal +++ b/servant-examples/servant-examples.cabal @@ -27,3 +27,17 @@ executable hackage , transformers hs-source-dirs: hackage default-language: Haskell2010 + +executable wai-middleware + main-is: wai-middleware.hs + build-depends: + aeson >= 0.8 + , base >= 4.7 + , servant + , servant-server + , text + , wai + , wai-extra + , warp + hs-source-dirs: wai-middleware + default-language: Haskell2010 diff --git a/servant-examples/wai-middleware/wai-middleware.hs b/servant-examples/wai-middleware/wai-middleware.hs new file mode 100644 index 00000000..ef772665 --- /dev/null +++ b/servant-examples/wai-middleware/wai-middleware.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +import Data.Aeson +import Data.Text +import GHC.Generics +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.RequestLogger +import Servant + +data Product = Product + { name :: Text + , brand :: Text + , current_price_eur :: Double + , available :: Bool + } deriving (Eq, Show, Generic) + +instance ToJSON Product + +products :: [Product] +products = [p1, p2] + + where p1 = Product "Haskell laptop sticker" + "GHC Industries" + 2.50 + True + + p2 = Product "Foldable USB drive" + "Well-Typed" + 13.99 + False + +type SimpleAPI = Get '[JSON] [Product] + +simpleAPI :: Proxy SimpleAPI +simpleAPI = Proxy + +server :: Server SimpleAPI +server = return products + +-- logStdout :: Middleware +-- i.e, logStdout :: Application -> Application +-- serve :: Proxy api -> Server api -> Application +-- so applying a middleware is really as simple as +-- applying a function to the result of 'serve' +app :: Application +app = logStdout (serve simpleAPI server) + +main :: IO () +main = run 8080 app From 4c86c7395cb1182651d8145b61ada6922f4afa89 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Fri, 24 Apr 2015 14:00:57 +0200 Subject: [PATCH 5/5] add an auth combinator example --- .../auth-combinator/auth-combinator.hs | 78 +++++++++++++++++++ servant-examples/servant-examples.cabal | 21 ++++- 2 files changed, 95 insertions(+), 4 deletions(-) create mode 100644 servant-examples/auth-combinator/auth-combinator.hs diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs new file mode 100644 index 00000000..3277c97e --- /dev/null +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Data.Aeson +import Data.ByteString (ByteString) +import Data.Text (Text) +import GHC.Generics +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp +import Servant +import Servant.Server.Internal + +-- Pretty much stolen/adapted from +-- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs + +type DBLookup = ByteString -> IO Bool + +isGoodCookie :: DBLookup +isGoodCookie = return . (== "good password") + +data AuthProtected + +instance HasServer rest => HasServer (AuthProtected :> rest) where + type ServerT' (AuthProtected :> rest) m = ServerT' rest m + + route Proxy a request respond = + case lookup "Cookie" (requestHeaders request) of + Nothing -> respond . succeedWith $ responseLBS status401 [] "Missing auth header." + Just v -> do + authGranted <- isGoodCookie v + if authGranted + then route (Proxy :: Proxy rest) a request respond + else respond . succeedWith $ responseLBS status403 [] "Invalid cookie." + +type PrivateAPI = Get '[JSON] [PrivateData] + +type PublicAPI = Get '[JSON] [PublicData] + +type API = "private" :> AuthProtected :> PrivateAPI + :<|> PublicAPI + +newtype PrivateData = PrivateData { ssshhh :: Text } + deriving (Eq, Show, Generic) + +instance ToJSON PrivateData + +newtype PublicData = PublicData { somedata :: Text } + deriving (Eq, Show, Generic) + +instance ToJSON PublicData + +api :: Proxy API +api = Proxy + +server :: Server API +server = return prvdata :<|> return pubdata + + where prvdata = [PrivateData "this is a secret"] + pubdata = [PublicData "this is a public piece of data"] + +main :: IO () +main = run 8080 (serve api server) + +{- Sample session: +$ curl http://localhost:8080/ +[{"somedata":"this is a public piece of data"}] +$ curl http://localhost:8080/private +Missing auth header. +$ curl -H "Cookie: good password" http://localhost:8080/private +[{"ssshhh":"this is a secret"}] +$ curl -H "Cookie: bad password" http://localhost:8080/private +Invalid cookie. +-} \ No newline at end of file diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index 65a92b98..f1edd49c 100644 --- a/servant-examples/servant-examples.cabal +++ b/servant-examples/servant-examples.cabal @@ -1,7 +1,8 @@ name: servant-examples version: 0.3 synopsis: Example programs for servant -description: Example programs for servant +description: Example programs for servant, + showcasing solutions to common needs. homepage: http://haskell-servant.github.io/ license: BSD3 license-file: LICENSE @@ -10,13 +11,10 @@ maintainer: alpmestan@gmail.com -- copyright: category: Web build-type: Simple --- extra-source-files: cabal-version: >=1.10 executable hackage main-is: hackage.hs - -- other-modules: - -- other-extensions: build-depends: aeson >= 0.8 , base >=4.7 @@ -41,3 +39,18 @@ executable wai-middleware , warp hs-source-dirs: wai-middleware default-language: Haskell2010 + +executable auth-combinator + main-is: auth-combinator.hs + build-depends: + aeson >= 0.8 + , base >= 4.7 + , bytestring + , http-types + , servant + , servant-server + , text + , wai + , warp + hs-source-dirs: auth-combinator + default-language: Haskell2010