Merge pull request #53 from haskell-servant/servant-examples

Add a servant-examples dir with 3 "classical" examples (and more to come?)

scripts/shell.nix

@@ -13,8 +13,10 @@ let modifiedHaskellPackages = haskellngPackages.override {
             ../servant-jquery {}) "--ghc-options=-Werror";
         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
 ])

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.

servant-examples/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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.
+-}

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"

servant-examples/servant-examples.cabal

@@ -0,0 +1,56 @@
+name:                servant-examples
+version:             0.3
+synopsis:            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
+author:              Alp Mestanogullari
+maintainer:          alpmestan@gmail.com
+-- copyright:           
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+
+executable hackage
+  main-is:             hackage.hs
+  build-depends:
+      aeson >= 0.8
+    , base >=4.7
+    , either
+    , servant
+    , servant-client
+    , text
+    , 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
+
+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

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

sources.txt

@@ -3,3 +3,4 @@ servant-client
 servant-docs
 servant-jquery
 servant-server
+servant-examples