test4

frameworks/Haskell/spock/spock.cabal

@@ -28,6 +28,10 @@ executable spock-exe
                      , mtl
                      , resourcet
                      , http-types
+                     , blaze-html
+                     , blaze-markup
+  other-modules:       Models.Fortune
+                     , Models.World
   default-language:    Haskell2010
 
 source-repository head

frameworks/Haskell/spock/src/Main.hs

@@ -3,47 +3,22 @@
 
 module Main where
 
-import           Control.Concurrent.Async           (mapConcurrently)
+import           Control.Concurrent.Async      (mapConcurrently)
 import           Control.Monad.IO.Class
-import           Data.Aeson                         hiding (json)
-import           Data.Maybe                         (catMaybes, listToMaybe)
-import qualified Data.Text                          as T
-import qualified Database.PostgreSQL.Simple         as PG
-import           Database.PostgreSQL.Simple.FromRow
+import           Data.Aeson                    hiding (json)
+import           Data.List                     (sort)
+import           Data.Maybe                    (catMaybes)
+import qualified Database.PostgreSQL.Simple    as PG
 import           GHC.Exts
 import           Network.HTTP.Types.Status
 import           System.Random
+import           Text.Blaze.Html.Renderer.Utf8
+import qualified Text.Blaze.Html5              as H
 import           Web.Spock.Safe
 
-
-data World = World
-    { _idW           :: Integer
-    , _randomNumberW :: Integer
-    } deriving (Show)
-
-
-instance ToJSON World where
-    toJSON w = object
-        [ "id"            .= _idW w
-        , "randomNumber"  .= _randomNumberW w
-        ]
-
-
-instance FromRow World where
-    fromRow = World <$> field <*> field
-
-
-fetchWorldById :: Int -> PG.Connection -> IO (Maybe World)
-fetchWorldById i c =
-    listToMaybe <$> PG.query c
-        "SELECT id, randomNumber FROM World WHERE id = (?)"
-        (PG.Only i)
-
-
-data Fortune = Fortune
-    { _idF      :: Integer
-    , _messageF :: T.Text
-    } deriving (Show)
+import           Models.Fortune
+import           Models.World
+import           Views.Fortune
 
 
 dbConn :: PoolOrConn PG.Connection
@@ -60,29 +35,42 @@ dbConn =
             (PoolCfg 5 5 60))
 
 
+blaze :: MonadIO m => H.Html -> ActionCtxT ctx m a
+blaze h = do
+    setHeader "Content-Type" "text/html"
+    lazyBytes $ renderHtml h
+{-# INLINE blaze #-}
+
+
 main :: IO ()
 main =
-    runSpock 3000 $ spock (defaultSpockCfg Nothing dbConn ()) $
-            -- | Test 1: JSON serialization
-        do  get "json" $
-                json $ Object (fromList [("message", "Hello, World!")])
-            -- | Test 2: Single database query
-            get "db" $
-                do  rand <- liftIO $ randomRIO (1, 10000)
-                    maybeWorld <- runQuery $ fetchWorldById rand
-                    case maybeWorld of
-                      Just w  -> json w
-                      Nothing -> setStatus status404 >> text "World not found."
-            -- | Test 3: Multiple database queries
-            get "queries" $
-                do  queries <- max 1 . min 500 <$> param' "queries"
-                    let runSQL core = runSpockIO core . runQuery . fetchWorldById =<< randomRIO (1, 10000)
-                    spockCore <- getSpockHeart
-                    maybeWorlds <- liftIO $ mapConcurrently (\_ -> runSQL spockCore) ([1..queries] :: [Int])
-                    json $ catMaybes maybeWorlds
-            -- | Test 4: Fortunes
-            get "fortune" $
-                do  liftIO $ putStrLn "test"
-            -- | Test 6: Plain text
-            get "plaintext" $
-                text "Hello, World!"
+    runSpock 3000 $ spock (defaultSpockCfg Nothing dbConn ()) $ do
+        -- | Test 1: JSON serialization
+        get "json" $
+            json $ Object (fromList [("message", "Hello, World!")])
+        -- | Test 2: Single database query
+        get "db" $ do
+            rand <- liftIO $ randomRIO (1, 10000)
+            maybeWorld <- runQuery $ fetchWorldById rand
+            case maybeWorld of
+              Just w  -> json w
+              Nothing -> setStatus status404 >> text "World not found."
+        -- | Test 3: Multiple database queries
+        get "queries" $ do
+            queries <- max 1 . min 500 <$> param' "queries"
+            let runSQL core = runSpockIO core . runQuery . fetchWorldById =<< randomRIO (1, 10000)
+            spockCore <- getSpockHeart
+            maybeWorlds <- liftIO $ mapConcurrently (\_ -> runSQL spockCore) ([1..queries] :: [Int])
+            json $ catMaybes maybeWorlds
+        -- | Test 4: Fortunes
+        get "fortune" $ do
+            fortunes <- runQuery fetchFortunes
+            let newFortune = Fortune 0 "Additional fortune added at request time."
+                sortedFortunes = sort (newFortune : fortunes)
+            blaze $ renderFortunes sortedFortunes
+        -- | Test 5: Database Updates
+        -- todo
+
+        -- | Test 6: Plain text
+        get "plaintext" $
+            text "Hello, World!"

frameworks/Haskell/spock/src/Models/Fortune.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Models.Fortune
+    ( Fortune(..)
+    , fetchFortunes
+    ) where
+
+import           Data.Aeson
+import           Data.Ord
+import qualified Data.Text                          as T
+import qualified Database.PostgreSQL.Simple         as PG
+import           Database.PostgreSQL.Simple.FromRow
+
+
+data Fortune = Fortune
+    { _idF      :: Integer
+    , _messageF :: T.Text
+    } deriving (Show)
+
+-- | JSON serialization
+instance ToJSON Fortune where
+    toJSON f = object
+        [ "id"       .= _idF f
+        , "message"  .= _messageF f
+        ]
+
+-- | Transforming a database row into a World datatype.
+instance FromRow Fortune where
+    fromRow = Fortune <$> field <*> field
+
+-- | For sorting purposes
+instance Eq Fortune where
+    (==) fa fb =
+        _idF fa      == _idF fb
+     && _messageF fa == _messageF fb
+
+instance Ord Fortune where
+    compare = comparing _messageF
+
+
+fetchFortunes :: PG.Connection -> IO [Fortune]
+fetchFortunes c = PG.query_ c "SELECT id, message FROM Fortune"

frameworks/Haskell/spock/src/Models/World.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Models.World
+    ( World(..)
+    , fetchWorldById
+    ) where
+
+import           Data.Aeson
+import           Data.Maybe
+import qualified Database.PostgreSQL.Simple         as PG
+import           Database.PostgreSQL.Simple.FromRow
+
+
+data World = World
+    { _idW           :: Integer
+    , _randomNumberW :: Integer
+    } deriving (Show)
+
+-- | JSON serialization
+instance ToJSON World where
+    toJSON w = object
+        [ "id"            .= _idW w
+        , "randomNumber"  .= _randomNumberW w
+        ]
+
+-- | Transforming a database row into a World datatype.
+instance FromRow World where
+    fromRow = World <$> field <*> field
+
+-- | Get a World by Id, this will return a Just World, or Nothing
+-- if the id is not in the database.
+fetchWorldById :: Int -> PG.Connection -> IO (Maybe World)
+fetchWorldById i c =
+    listToMaybe <$> PG.query c
+        "SELECT id, randomNumber FROM World WHERE id = (?)"
+        (PG.Only i)

frameworks/Haskell/spock/src/Views/Fortune.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Views.Fortune
+    ( renderFortunes
+    ) where
+
+import           Control.Monad    (forM_)
+import           Text.Blaze.Html5 as H
+
+import           Models.Fortune
+
+
+renderFortunes :: [Fortune] -> Html
+renderFortunes fs =
+    docTypeHtml $ do
+        H.head $
+            H.title "Fortunes"
+        H.body $
+            H.table $
+                H.tr $ do
+                    H.th "id"
+                    H.th "message"
+                    forM_ fs $ \f ->
+                        H.tr $ do
+                            H.td $ toHtml $ _idF f
+                            H.td $ toHtml $ _messageF f