Remove servant-examples (again)

This commit is contained in:
Julian K. Arni 2016-03-18 15:10:56 +01:00 committed by Sönke Hahn
parent 4e90308b85
commit 79029089db
14 changed files with 0 additions and 990 deletions

View file

@ -1,124 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson hiding ((.:))
import Data.ByteString (ByteString)
import Data.Monoid ((<>))
import Data.Map (Map, fromList)
import qualified Data.Map as Map
import Data.Text (Text)
import GHC.Generics
import Network.Wai
import Network.Wai.Handler.Warp
import Servant
import Servant.Server.Experimental.Auth
-- | This file contains an authenticated server using servant's generalized
-- authentication support. Our basic authentication scheme is trivial: we
-- look for a cookie named "servant-auth-cookie" and its value will contain
-- a key, which we use to lookup a User. Obviously this is an absurd example,
-- but we pick something simple and non-standard to show you how to extend
-- servant's support for authentication.
-- | A user type that we "fetch from the database" after
-- performing authentication
newtype User = User { unUser :: Text }
-- | A (pure) database mapping keys to users.
database :: Map ByteString User
database = fromList [ ("key1", User "Anne Briggs")
, ("key2", User "Bruce Cockburn")
, ("key3", User "Ghédalia Tazartès")
]
-- | A method that, when given a password, will return a User.
-- This is our bespoke (and bad) authentication logic.
lookupUser :: ByteString -> ExceptT ServantErr IO User
lookupUser key = case Map.lookup key database of
Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
Just usr -> return usr
-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User
-- we look for a Cookie and pass the value of the cookie to `lookupUser`.
authHandler :: AuthHandler Request User
authHandler =
let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
Nothing -> throwE (err401 { errBody = "Missing auth header" })
Just authCookieKey -> lookupUser authCookieKey
in mkAuthHandler handler
-- | Data types that will be returned from various api endpoints
newtype PrivateData = PrivateData { ssshhh :: Text }
deriving (Eq, Show, Generic)
instance ToJSON PrivateData
newtype PublicData = PublicData { somedata :: Text }
deriving (Eq, Show, Generic)
instance ToJSON PublicData
-- | Our private API that we want to be auth-protected.
type PrivateAPI = Get '[JSON] [PrivateData]
-- | Our public API that doesn't have any protection
type PublicAPI = Get '[JSON] [PublicData]
-- | Our API, with auth-protection
type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI
:<|> "public" :> PublicAPI
-- | A value holding our type-level API
api :: Proxy API
api = Proxy
-- | We need to specify the data returned after authentication
type instance AuthServerData (AuthProtect "cookie-auth") = User
-- | The context that will be made available to request handlers. We supply the
-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance
-- of 'AuthProtect' can extract the handler and run it on the request.
serverContext :: Context (AuthHandler Request User ': '[])
serverContext = authHandler :. EmptyContext
-- | Our API, where we provide all the author-supplied handlers for each end
-- point. Note that 'privateDataFunc' is a function that takes 'User' as an
-- argument. We dont' worry about the authentication instrumentation here,
-- that is taken care of by supplying context
server :: Server API
server = privateDataFunc :<|> return publicData
where privateDataFunc (User name) =
return [PrivateData ("this is a secret: " <> name)]
publicData = [PublicData "this is a public piece of data"]
-- | run our server
main :: IO ()
main = run 8080 (serveWithContext api serverContext server)
{- Sample Session:
$ curl -XGET localhost:8080/private
Missing auth header
>>>>>>> modify auth-combinator example for gen auth
>>>>>>> 8246c1f... modify auth-combinator example for gen auth
$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"
[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]
$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key"
Invalid Cookie
$ curl -XGET localhost:8080/public
[{"somedata":"this is a public piece of data"}]
-}

View file

@ -1,105 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import Data.Aeson (ToJSON)
import Data.Proxy (Proxy (Proxy))
import Data.Text (Text)
import GHC.Generics (Generic)
import Network.Wai.Handler.Warp (run)
import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,
Get, JSON)
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
import Servant.Server (BasicAuthCheck (BasicAuthCheck),
BasicAuthResult( Authorized
, Unauthorized
),
Context ((:.), EmptyContext), Server,
serveWithContext)
-- | let's define some types that our API returns.
-- | private data that needs protection
newtype PrivateData = PrivateData { ssshhh :: Text }
deriving (Eq, Show, Generic)
instance ToJSON PrivateData
-- | public data that anyone can use.
newtype PublicData = PublicData { somedata :: Text }
deriving (Eq, Show, Generic)
instance ToJSON PublicData
-- | A user we'll grab from the database when we authenticate someone
newtype User = User { userName :: Text }
deriving (Eq, Show)
-- | a type to wrap our public api
type PublicAPI = Get '[JSON] [PublicData]
-- | a type to wrap our private api
type PrivateAPI = Get '[JSON] PrivateData
-- | our API
type API = "public" :> PublicAPI
:<|> "private" :> BasicAuth "foo-realm" User :> PrivateAPI
-- | a value holding a proxy of our API type
api :: Proxy API
api = Proxy
-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
authCheck :: BasicAuthCheck User
authCheck =
let check (BasicAuthData username password) =
if username == "servant" && password == "server"
then return (Authorized (User "servant"))
else return Unauthorized
in BasicAuthCheck check
-- | We need to supply our handlers with the right Context. In this case,
-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value
-- tagged with "foo-tag" This context is then supplied to 'server' and threaded
-- to the BasicAuth HasServer handlers.
serverContext :: Context (BasicAuthCheck User ': '[])
serverContext = authCheck :. EmptyContext
-- | an implementation of our server. Here is where we pass all the handlers to our endpoints.
-- In particular, for the BasicAuth protected handler, we need to supply a function
-- that takes 'User' as an argument.
server :: Server API
server =
let publicAPIHandler = return [PublicData "foo", PublicData "bar"]
privateAPIHandler (user :: User) = return (PrivateData (userName user))
in publicAPIHandler :<|> privateAPIHandler
-- | hello, server!
main :: IO ()
main = run 8080 (serveWithContext api serverContext server)
{- Sample session
$ curl -XGET localhost:8080/public
[{"somedata":"foo"},{"somedata":"bar"}
$ curl -iXGET localhost:8080/private
HTTP/1.1 401 Unauthorized
transfer-encoding: chunked
Date: Thu, 07 Jan 2016 22:36:38 GMT
Server: Warp/3.1.8
WWW-Authenticate: Basic realm="foo-realm"
$ curl -iXGET localhost:8080/private -H "Authorization: Basic c2VydmFudDpzZXJ2ZXI="
HTTP/1.1 200 OK
transfer-encoding: chunked
Date: Thu, 07 Jan 2016 22:37:58 GMT
Server: Warp/3.1.8
Content-Type: application/json
{"ssshhh":"servant"}
-}

View file

@ -1,148 +0,0 @@
name: servant-examples
version: 0.5
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: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2015-2016 Servant Contributors
category: Web
build-type: Simple
cabal-version: >=1.10
bug-reports: http://github.com/haskell-servant/servant/issues
source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
executable tutorial
main-is: tutorial.hs
other-modules: T1, T2, T3, T4, T5, T6, T7, T8, T9, T10
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-unused-imports
build-depends:
aeson >= 0.8
, base >= 4.7 && < 5
, bytestring
, directory
, http-types
, js-jquery
, lucid
, random
, servant == 0.5.*
, servant-docs == 0.5.*
, servant-js == 0.5.*
, servant-lucid == 0.5.*
, servant-server == 0.5.*
, text
, time
, transformers
, transformers-compat
, wai
, warp
hs-source-dirs: tutorial
default-language: Haskell2010
executable t8-main
main-is: t8-main.hs
other-modules: T3, T8
hs-source-dirs: tutorial
default-language: Haskell2010
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
build-depends:
aeson
, base >= 4.7 && < 5
, http-client > 0.4 && < 0.5
, servant == 0.5.*
, servant-client == 0.5.*
, servant-server == 0.5.*
, transformers
, transformers-compat
, wai
executable hackage
main-is: hackage.hs
build-depends:
aeson >= 0.8
, base >=4.7 && < 5
, http-client > 0.4 && < 0.5
, servant == 0.5.*
, servant-client == 0.5.*
, text
, transformers
, transformers-compat
hs-source-dirs: hackage
default-language: Haskell2010
executable wai-middleware
main-is: wai-middleware.hs
build-depends:
aeson >= 0.8
, base >= 4.7 && < 5
, servant == 0.5.*
, servant-server == 0.5.*
, text
, wai
, wai-extra
, warp
hs-source-dirs: wai-middleware
default-language: Haskell2010
executable basic-auth
main-is: basic-auth.hs
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
build-depends:
aeson >= 0.8
, base >= 4.7 && < 5
, bytestring
, http-types
, servant == 0.5.*
, servant-server == 0.5.*
, text
, wai
, warp
hs-source-dirs: basic-auth
default-language: Haskell2010
executable auth-combinator
main-is: auth-combinator.hs
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
build-depends:
aeson >= 0.8
, base >= 4.7 && < 5
, bytestring
, containers
, http-types
, servant == 0.5.*
, servant-server == 0.5.*
, text
, transformers
, wai
, warp
hs-source-dirs: auth-combinator
default-language: Haskell2010
executable socket-io-chat
main-is: socket-io-chat.hs
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
other-modules: Chat
build-depends:
aeson >= 0.8
, base >= 4.7 && < 5
, bytestring
, http-types
, servant == 0.5.*
, servant-server == 0.5.*
, socket-io
, engine-io
, engine-io-wai
, text
, wai
, warp
, transformers
, stm
, mtl
ghc-options: -Wall -O2 -threaded
hs-source-dirs: socket-io-chat
default-language: Haskell2010

View file

@ -1,54 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
import Data.Monoid ((<>))
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Network.EngineIO.Wai
import Network.Wai
import Network.Wai.Handler.Warp (run)
import Servant
import qualified Control.Concurrent.STM as STM
import qualified Network.SocketIO as SocketIO
import Chat (ServerState (..), eioServer)
type API = "socket.io" :> Raw
:<|> Raw
api :: Proxy API
api = Proxy
server :: WaiMonad () -> Server API
server sHandler = socketIOHandler
:<|> serveDirectory "socket-io-chat/resources"
where
socketIOHandler req respond = toWaiApplication sHandler req respond
app :: WaiMonad () -> Application
app sHandler = serve api $ server sHandler
port :: Int
port = 3001
main :: IO ()
main = do
state <- ServerState <$> STM.newTVarIO 0
sHandler <- SocketIO.initialize waiAPI (eioServer state)
putStrLn $ "Running on " <> show port
run port $ app sHandler

View file

@ -1,45 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T1 where
import Data.Aeson
import Data.Time.Calendar
import GHC.Generics
import Network.Wai
import Servant
data User = User
{ name :: String
, age :: Int
, email :: String
, registration_date :: Day
} deriving (Eq, Show, Generic)
#if !MIN_VERSION_aeson(0,10,0)
-- orphan ToJSON instance for Day. necessary to derive one for User
instance ToJSON Day where
-- display a day in YYYY-mm-dd format
toJSON d = toJSON (showGregorian d)
#endif
instance ToJSON User
type UserAPI = "users" :> Get '[JSON] [User]
users :: [User]
users =
[ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1)
, User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1)
]
userAPI :: Proxy UserAPI
userAPI = Proxy
server :: Server UserAPI
server = return users
app :: Application
app = serve userAPI server

View file

@ -1,71 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T10 where
import Data.ByteString.Lazy (ByteString)
import Data.Text.Lazy (pack)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Network.HTTP.Types
import Network.Wai
import Servant
import Servant.Docs
import qualified T3
type DocsAPI = T3.API :<|> Raw
instance ToCapture (Capture "x" Int) where
toCapture _ = DocCapture "x" "(integer) position on the x axis"
instance ToCapture (Capture "y" Int) where
toCapture _ = DocCapture "y" "(integer) position on the y axis"
instance ToSample T3.Position where
toSamples _ = singleSample (T3.Position 3 14)
instance ToParam (QueryParam "name" String) where
toParam _ =
DocQueryParam "name"
["Alp", "John Doe", "..."]
"Name of the person to say hello to."
Normal
instance ToSample T3.HelloMessage where
toSamples _ =
[ ("When a value is provided for 'name'", T3.HelloMessage "Hello, Alp")
, ("When 'name' is not specified", T3.HelloMessage "Hello, anonymous coward")
]
ci :: T3.ClientInfo
ci = T3.ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]
instance ToSample T3.ClientInfo where
toSamples _ = singleSample ci
instance ToSample T3.Email where
toSamples _ = singleSample (T3.emailForClient ci)
api :: Proxy DocsAPI
api = Proxy
docsBS :: ByteString
docsBS = encodeUtf8
. pack
. markdown
$ docsWithIntros [intro] T3.api
where intro = DocIntro "Welcome" ["This is our super webservice's API.", "Enjoy!"]
server :: Server DocsAPI
server = T3.server :<|> serveDocs
where serveDocs _ respond =
respond $ responseLBS ok200 [plain] docsBS
plain = ("Content-Type", "text/plain")
app :: Application
app = serve api server

View file

@ -1,52 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T2 where
import Data.Aeson
import Data.Time.Calendar
import GHC.Generics
import Network.Wai
import Servant
data User = User
{ name :: String
, age :: Int
, email :: String
, registration_date :: Day
} deriving (Eq, Show, Generic)
#if !MIN_VERSION_aeson(0,10,0)
-- orphan ToJSON instance for Day. necessary to derive one for User
instance ToJSON Day where
-- display a day in YYYY-mm-dd format
toJSON d = toJSON (showGregorian d)
#endif
instance ToJSON User
type UserAPI = "users" :> Get '[JSON] [User]
:<|> "albert" :> Get '[JSON] User
:<|> "isaac" :> Get '[JSON] User
isaac :: User
isaac = User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1)
albert :: User
albert = User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1)
users :: [User]
users = [isaac, albert]
userAPI :: Proxy UserAPI
userAPI = Proxy
server :: Server UserAPI
server = return users
:<|> return albert
:<|> return isaac
app :: Application
app = serve userAPI server

View file

@ -1,84 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T3 where
import Control.Monad.Trans.Except
import Data.Aeson
import Data.List
import GHC.Generics
import Network.Wai
import Servant
data Position = Position
{ x :: Int
, y :: Int
} deriving (Show, Generic)
instance FromJSON Position
instance ToJSON Position
newtype HelloMessage = HelloMessage { msg :: String }
deriving (Show, Generic)
instance FromJSON HelloMessage
instance ToJSON HelloMessage
data ClientInfo = ClientInfo
{ name :: String
, email :: String
, age :: Int
, interested_in :: [String]
} deriving (Show, Generic)
instance FromJSON ClientInfo
instance ToJSON ClientInfo
data Email = Email
{ from :: String
, to :: String
, subject :: String
, body :: String
} deriving (Show, Generic)
instance FromJSON Email
instance ToJSON Email
emailForClient :: ClientInfo -> Email
emailForClient c = Email from' to' subject' body'
where from' = "great@company.com"
to' = email c
subject' = "Hey " ++ name c ++ ", we miss you!"
body' = "Hi " ++ name c ++ ",\n\n"
++ "Since you've recently turned " ++ show (age c)
++ ", have you checked out our latest "
++ intercalate ", " (interested_in c)
++ " products? Give us a visit!"
type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position
:<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage
:<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email
api :: Proxy API
api = Proxy
server :: Server API
server = position
:<|> hello
:<|> marketing
where position :: Int -> Int -> ExceptT ServantErr IO Position
position x y = return (Position x y)
hello :: Maybe String -> ExceptT ServantErr IO HelloMessage
hello mname = return . HelloMessage $ case mname of
Nothing -> "Hello, anonymous coward"
Just n -> "Hello, " ++ n
marketing :: ClientInfo -> ExceptT ServantErr IO Email
marketing clientinfo = return (emailForClient clientinfo)
app :: Application
app = serve api server

View file

@ -1,63 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T4 where
import Data.Aeson
import Data.Foldable (foldMap)
import GHC.Generics
import Lucid
import Network.Wai
import Servant
import Servant.HTML.Lucid
data Person = Person
{ firstName :: String
, lastName :: String
, age :: Int
} deriving Generic -- for the JSON instance
-- JSON serialization
instance ToJSON Person
-- HTML serialization of a single person
instance ToHtml Person where
toHtml person =
tr_ $ do
td_ (toHtml $ firstName person)
td_ (toHtml $ lastName person)
td_ (toHtml . show $ age person)
toHtmlRaw = toHtml
-- HTML serialization of a list of persons
instance ToHtml [Person] where
toHtml persons = table_ $ do
tr_ $ do
th_ "first name"
th_ "last name"
th_ "age"
foldMap toHtml persons
toHtmlRaw = toHtml
persons :: [Person]
persons =
[ Person "Isaac" "Newton" 372
, Person "Albert" "Einstein" 136
]
type PersonAPI = "persons" :> Get '[JSON, HTML] [Person]
personAPI :: Proxy PersonAPI
personAPI = Proxy
server :: Server PersonAPI
server = return persons
app :: Application
app = serve personAPI server

View file

@ -1,37 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T5 where
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson
import GHC.Generics
import Network.Wai
import Servant
import System.Directory
type IOAPI = "myfile.txt" :> Get '[JSON] FileContent
ioAPI :: Proxy IOAPI
ioAPI = Proxy
newtype FileContent = FileContent
{ content :: String }
deriving Generic
instance ToJSON FileContent
server :: Server IOAPI
server = do
exists <- liftIO (doesFileExist "myfile.txt")
if exists
then liftIO (readFile "myfile.txt") >>= return . FileContent
else throwE custom404Err
where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." }
app :: Application
app = serve ioAPI server

View file

@ -1,18 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T6 where
import Network.Wai
import Servant
type API = "code" :> Raw
api :: Proxy API
api = Proxy
server :: Server API
server = serveDirectory "tutorial"
app :: Application
app = serve api server

View file

@ -1,33 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T7 where
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Network.Wai
import Servant
type ReaderAPI = "a" :> Get '[JSON] Int
:<|> "b" :> Get '[JSON] String
readerAPI :: Proxy ReaderAPI
readerAPI = Proxy
readerServerT :: ServerT ReaderAPI (Reader String)
readerServerT = a :<|> b
where a :: Reader String Int
a = return 1797
b :: Reader String String
b = ask
readerServer :: Server ReaderAPI
readerServer = enter readerToEither readerServerT
where readerToEither :: Reader String :~> ExceptT ServantErr IO
readerToEither = Nat $ \r -> return (runReader r "hi")
app :: Application
app = serve readerAPI readerServer

View file

@ -1,105 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T9 where
import Control.Applicative
import Control.Monad.IO.Class
import Data.Aeson
import Data.Text (Text)
import GHC.Generics
import Network.Wai
import Servant
import Servant.JS
import System.Random
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Language.Javascript.JQuery as JQ
data Point = Point
{ x :: Double
, y :: Double
} deriving Generic
instance ToJSON Point
randomPoint :: MonadIO m => m Point
randomPoint = liftIO . getStdRandom $ \g ->
let (rx, g') = randomR (-1, 1) g
(ry, g'') = randomR (-1, 1) g'
in (Point rx ry, g'')
data Search a = Search
{ query :: Text
, results :: [a]
} deriving Generic
mkSearch :: Text -> [a] -> Search a
mkSearch = Search
instance ToJSON a => ToJSON (Search a)
data Book = Book
{ author :: Text
, title :: Text
, year :: Int
} deriving Generic
instance ToJSON Book
book :: Text -> Text -> Int -> Book
book = Book
books :: [Book]
books =
[ book "Paul Hudak" "The Haskell School of Expression: Learning Functional Programming through Multimedia" 2000
, book "Bryan O'Sullivan, Don Stewart, and John Goerzen" "Real World Haskell" 2008
, book "Miran Lipovača" "Learn You a Haskell for Great Good!" 2011
, book "Graham Hutton" "Programming in Haskell" 2007
, book "Simon Marlow" "Parallel and Concurrent Programming in Haskell" 2013
, book "Richard Bird" "Introduction to Functional Programming using Haskell" 1998
]
searchBook :: Monad m => Maybe Text -> m (Search Book)
searchBook Nothing = return (mkSearch "" books)
searchBook (Just q) = return (mkSearch q books')
where books' = filter (\b -> q' `T.isInfixOf` T.toLower (author b)
|| q' `T.isInfixOf` T.toLower (title b)
)
books
q' = T.toLower q
type API = "point" :> Get '[JSON] Point
:<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book)
type API' = API :<|> Raw
api :: Proxy API
api = Proxy
api' :: Proxy API'
api' = Proxy
server :: Server API
server = randomPoint
:<|> searchBook
server' :: Server API'
server' = server
:<|> serveDirectory "tutorial/t9"
apiJS :: Text
apiJS = jsForAPI api jquery
writeJSFiles :: IO ()
writeJSFiles = do
TIO.writeFile "tutorial/t9/api.js" apiJS
jq <- TIO.readFile =<< JQ.file
TIO.writeFile "tutorial/t9/jq.js" jq
app :: Application
app = serve api' server'

View file

@ -1,51 +0,0 @@
{-# 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 -> Context context -> 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