diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index 0dc4e22a..371a4fd3 100644 --- a/servant-examples/servant-examples.cabal +++ b/servant-examples/servant-examples.cabal @@ -13,6 +13,45 @@ category: Web build-type: Simple cabal-version: >=1.10 +executable tutorial + main-is: tutorial.hs + other-modules: T1, T2, T3, T4, T5, T6, T7, T8, T9, T10 + build-depends: + aeson >= 0.8 + , base >= 4.7 + , bytestring + , directory + , either + , http-types + , js-jquery + , lucid + , random + , servant + , servant-docs + , servant-jquery + , servant-lucid + , servant-server + , text + , time + , transformers + , wai + , warp + hs-source-dirs: tutorial + default-language: Haskell2010 + +executable t8-main + main-is: t8-main.hs + hs-source-dirs: tutorial + default-language: Haskell2010 + build-depends: + aeson + , base + , either + , servant + , servant-client + , servant-server + , wai + executable hackage main-is: hackage.hs build-depends: diff --git a/servant-examples/tutorial/T1.hs b/servant-examples/tutorial/T1.hs new file mode 100644 index 00000000..9fb93c8c --- /dev/null +++ b/servant-examples/tutorial/T1.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# 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) + +-- 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) + +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 diff --git a/servant-examples/tutorial/T10.hs b/servant-examples/tutorial/T10.hs new file mode 100644 index 00000000..39e48e04 --- /dev/null +++ b/servant-examples/tutorial/T10.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +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 T3.Position where + toSample _ = Just (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 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 T3.ClientInfo where + toSample _ = Just ci + +instance ToSample T3.Email T3.Email where + toSample _ = Just (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 diff --git a/servant-examples/tutorial/T2.hs b/servant-examples/tutorial/T2.hs new file mode 100644 index 00000000..69ded18c --- /dev/null +++ b/servant-examples/tutorial/T2.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# 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) + +-- 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) + +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 diff --git a/servant-examples/tutorial/T3.hs b/servant-examples/tutorial/T3.hs new file mode 100644 index 00000000..dcff930b --- /dev/null +++ b/servant-examples/tutorial/T3.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +module T3 where + +import Control.Monad.Trans.Either +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 -> EitherT ServantErr IO Position + position x y = return (Position x y) + + hello :: Maybe String -> EitherT ServantErr IO HelloMessage + hello mname = return . HelloMessage $ case mname of + Nothing -> "Hello, anonymous coward" + Just n -> "Hello, " ++ n + + marketing :: ClientInfo -> EitherT ServantErr IO Email + marketing clientinfo = return (emailForClient clientinfo) + +app :: Application +app = serve api server diff --git a/servant-examples/tutorial/T4.hs b/servant-examples/tutorial/T4.hs new file mode 100644 index 00000000..595eabcb --- /dev/null +++ b/servant-examples/tutorial/T4.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +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 p = + tr_ $ do + td_ (toHtml $ firstName p) + td_ (toHtml $ lastName p) + td_ (toHtml . show $ age p) + + toHtmlRaw = toHtml + +-- HTML serialization of a list of persons +instance ToHtml [Person] where + toHtml persons = table_ $ do + tr_ $ do + td_ "first name" + td_ "last name" + td_ "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 diff --git a/servant-examples/tutorial/T5.hs b/servant-examples/tutorial/T5.hs new file mode 100644 index 00000000..0811fd9b --- /dev/null +++ b/servant-examples/tutorial/T5.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +module T5 where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +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 left custom404Err + + where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } + +app :: Application +app = serve ioAPI server diff --git a/servant-examples/tutorial/T6.hs b/servant-examples/tutorial/T6.hs new file mode 100644 index 00000000..c0abb1df --- /dev/null +++ b/servant-examples/tutorial/T6.hs @@ -0,0 +1,18 @@ +{-# 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 diff --git a/servant-examples/tutorial/T7.hs b/servant-examples/tutorial/T7.hs new file mode 100644 index 00000000..d67cfcd4 --- /dev/null +++ b/servant-examples/tutorial/T7.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module T7 where + +import Control.Monad.Trans.Either +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 :~> EitherT ServantErr IO + readerToEither = Nat $ \r -> return (runReader r "hi") + +app :: Application +app = serve readerAPI readerServer diff --git a/servant-examples/tutorial/T8.hs b/servant-examples/tutorial/T8.hs new file mode 100644 index 00000000..089702bc --- /dev/null +++ b/servant-examples/tutorial/T8.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module T8 where + +import Control.Monad.Trans.Either +import Data.Aeson +import Servant +import Servant.Client + +import T3 + +position :: Int -- ^ value for "x" + -> Int -- ^ value for "y" + -> EitherT ServantError IO Position + +hello :: Maybe String -- ^ an optional value for "name" + -> EitherT ServantError IO HelloMessage + +marketing :: ClientInfo -- ^ value for the request body + -> EitherT ServantError IO Email + +position :<|> hello :<|> marketing = client api baseUrl + +baseUrl :: BaseUrl +baseUrl = BaseUrl Http "localhost" 8081 + +queries :: EitherT ServantError IO (Position, HelloMessage, Email) +queries = do + pos <- position 10 10 + msg <- hello (Just "servant") + em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) + return (pos, msg, em) + +run :: IO () +run = do + res <- runEitherT queries + case res of + Left err -> putStrLn $ "Error: " ++ show err + Right (pos, msg, em) -> do + print pos + print msg + print em diff --git a/servant-examples/tutorial/T9.hs b/servant-examples/tutorial/T9.hs new file mode 100644 index 00000000..1b0633f0 --- /dev/null +++ b/servant-examples/tutorial/T9.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +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.JQuery +import System.Random + +import qualified Data.Text as T +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 :: String +apiJS = jsForAPI api + +writeJSFiles :: IO () +writeJSFiles = do + writeFile "tutorial/t9/api.js" apiJS + jq <- readFile =<< JQ.file + writeFile "tutorial/t9/jq.js" jq + +app :: Application +app = serve api' server' diff --git a/servant-examples/tutorial/t8-main.hs b/servant-examples/tutorial/t8-main.hs new file mode 100644 index 00000000..b70d5a61 --- /dev/null +++ b/servant-examples/tutorial/t8-main.hs @@ -0,0 +1,4 @@ +import T8 + +main :: IO () +main = run diff --git a/servant-examples/tutorial/t9/index.html b/servant-examples/tutorial/t9/index.html new file mode 100644 index 00000000..7ec49c70 --- /dev/null +++ b/servant-examples/tutorial/t9/index.html @@ -0,0 +1,26 @@ + + + + + + Tutorial - 9 - servant-jquery + + +

Books

+ +
+

Results for ""

+ +
+
+

Approximating π

+

Count: 0

+

Successes: 0

+

+ + + + + + \ No newline at end of file diff --git a/servant-examples/tutorial/t9/ui.js b/servant-examples/tutorial/t9/ui.js new file mode 100644 index 00000000..755de45b --- /dev/null +++ b/servant-examples/tutorial/t9/ui.js @@ -0,0 +1,61 @@ +/* book search */ +function updateResults(data) +{ + console.log(data); + $('#results').html(""); + $('#query').text("\"" + data.query + "\""); + for(var i = 0; i < data.results.length; i++) + { + $('#results').append(renderBook(data.results[i])); + } +} + +function renderBook(book) +{ + var li = '
  • ' + book.title + ', ' + + book.author + ' - ' + book.year + '
  • '; + return li; +} + +function searchBooks() +{ + var q = $('#q').val(); + getbooks(q, updateResults, console.log) +} + +searchBooks(); +$('#q').keyup(function() { + searchBooks(); +}); + +/* approximating pi */ +var count = 0; +var successes = 0; + +function f(data) +{ + var x = data.x, y = data.y; + if(x*x + y*y <= 1) + { + successes++; + } + + count++; + + update('#count', count); + update('#successes', successes); + update('#pi', 4*successes/count); +} + +function update(id, val) +{ + $(id).text(val); +} + +function refresh() +{ + getpoint(f, console.log); +} + +window.setInterval(refresh, 200); + diff --git a/servant-examples/tutorial/tutorial.hs b/servant-examples/tutorial/tutorial.hs new file mode 100644 index 00000000..55f0408b --- /dev/null +++ b/servant-examples/tutorial/tutorial.hs @@ -0,0 +1,39 @@ +import Network.Wai +import Network.Wai.Handler.Warp +import System.Environment + +import qualified T1 +import qualified T2 +import qualified T3 +import qualified T4 +import qualified T5 +import qualified T6 +import qualified T7 +import qualified T9 +import qualified T10 + +app :: String -> (Application -> IO ()) -> IO () +app n f = case n of + "1" -> f T1.app + "2" -> f T2.app + "3" -> f T3.app + "4" -> f T4.app + "5" -> f T5.app + "6" -> f T6.app + "7" -> f T7.app + "8" -> f T3.app + "9" -> T9.writeJSFiles >> f T9.app + "10" -> f T10.app + _ -> usage + +main :: IO () +main = do + args <- getArgs + case args of + [n] -> app n (run 8081) + _ -> usage + +usage :: IO () +usage = do + putStrLn "Usage:\t tutorial N" + putStrLn "\t\twhere N is the number of the example you want to run."