Implementation of REST GET of feedings.

main.hs

{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules, NoMonomorphismRestriction #-}

import Database.MongoDB as M
import Control.Monad.Trans (liftIO)
import System.Locale
import Data.Time
import Data.Time.Format
import Data.Bson.Json
import Data.Aeson.Encode
import Data.Aeson
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Static
import Web.Scotty

clearAllBreastFeedings = M.delete (select [] "breastfeeding")

insertBreastFeedings = insertMany "breastfeeding" [
    ["date" =: (dateFromString "23-03-2012"), "side" =: "L", "time" =: (timeFromString "22:30"), "excrement" =: "P", "remarks" =: ""],
    ["date" =: (dateFromString "24-03-2012"), "side" =: "L/R", "time" =: (timeFromString "02:30"), "excrement" =: "PB", "remarks" =: "Spuugje"],
    ["date" =: (dateFromString "23-03-2012"), "side" =: "R", "time" =: (timeFromString "22:45"), "excrement" =: "B", "remarks" =: "huilen"] ]

insertFeeding :: Document -> M.Action IO M.Value
insertFeeding b = insert "breastfeeding" b

allBreastFeedings :: M.Action IO [Document]
allBreastFeedings = rest =<< find (select [] "breastfeeding") {sort = ["date" =: -1, "time" =: -1]}

temp = do
  clearAllBreastFeedings
  insertBreastFeedings
  allBreastFeedings

printDocs :: String -> [Document] -> M.Action IO ()
printDocs title docs = liftIO $ putStrLn title >> mapM_ (print . exclude ["_id"]) docs

printJsonDocs jsonDocs = liftIO $ mapM_ (print) jsonDocs

--jsonDocs :: [Document] -> Object
jsonDocs docs = map (documentToJson . exclude ["_id"]) docs

dateFromString :: String -> UTCTime
dateFromString s = readTime defaultTimeLocale "%d-%m-%Y" s :: UTCTime

--parse time in the form of xx:xx to a UTCTime
timeFromString :: String -> UTCTime
timeFromString s = readTime defaultTimeLocale "%H:%M" s :: UTCTime

--Document to JSON
documentToJson d = encode d

exampleJson = "{\"time\":\"1970-01-01T02:30:00Z\",\"date\":\"2012-03-24T00:00:00Z\",\"remarks\":\"Spuugje\",\"excrement\":\"PB\",\"side\":\"L/R\"}"

main :: IO ()
main = scotty 3000 $ do
    middleware logStdoutDev
    middleware $ staticPolicy (noDots >-> addBase "static")

    get "/api/feedings" $ do
      pipe <- liftIO $ runIOE $ connect (host "127.0.0.1")
      e <- liftIO $ access pipe master "breastfeeds" temp --allBreastFeedings
      Web.Scotty.json $ case e of
                  Left error -> [] 
                  Right success -> success 

--    post "/api/feedings" $ do
--        v <- jsonData
--        json $ case v of
--                Quux -> Quux
--                Bar i -> Bar $ i + 1
--                Baz (f,s) -> Baz (f + 0.5, s)