Azure/Happstack/tablestorage

azure.hs

module Main where

import Data.Maybe
import Control.Monad
import Control.Monad.Trans
import System.Time
import System.Directory
import Happstack.Server
import qualified Text.Blaze.Html4.Strict as H
import qualified Text.Blaze.Html4.Strict.Attributes as A
import Network.TableStorage
import Text.Blaze ((!), toValue)

-- Replace developmentAccount with defaultAccount "myaccountkey" "myaccountname" "myaccounthost" to use Azure in production
account :: Account
account = developmentAccount 

newId :: IO String
newId = do
  (TOD seconds picos) <- getClockTime
  return $ show (9999999999 - seconds) ++ show picos

postNote :: ServerPartT IO Response
postNote = do 
  methodM POST
  tmp <- liftIO getTemporaryDirectory 
  decodeBody $ defaultBodyPolicy tmp 0 1000 1000
  text <- look "text"
  author <- look "author"
  partition <- look "partition"
  result <- liftIO $ do
    id <- newId
    let entity = Entity { entityKey = EntityKey { ekPartitionKey = partition, 
                                                  ekRowKey = id }, 
                          entityColumns = [ ("text", EdmString $ Just text),
                                            ("author", EdmString $ Just author)] }
    insertEntity account "notes" entity
  case result of
    Left err -> internalServerError $ toResponse err
    Right _ -> seeOther ("?partition=" ++ partition) $ toResponse ()

getNotes :: ServerPartT IO Response
getNotes = do
  methodM GET
  partition <- look "partition" `mplus` return "default"
  let query = defaultEntityQuery { eqPageSize = Just 10,
                                   eqFilter = Just $ CompareString "PartitionKey" Equal partition }
  result <- liftIO $ queryEntities account "notes" query
  case result of
    Left err -> internalServerError $ toResponse err
    Right notes -> ok $ setHeader "Content-Type" "text/html" $ toResponse $ root partition notes
    
root :: String -> [Entity] -> H.Html
root partition notes = H.html $ do
  H.head $ 
    H.title $ H.toHtml "Notes"
  H.body $ do
    H.h1 $ H.toHtml "Add Note"
    H.form ! A.method (toValue "POST") $ do
      H.input ! A.type_ (toValue "hidden") ! A.name (toValue "partition") ! A.value (toValue partition)
      H.div $ do
        H.label ! A.for (toValue "text") $ H.toHtml "Text: "
        H.input ! A.type_ (toValue "text") ! A.name (toValue "text")
      H.div $ do
        H.label ! A.for (toValue "author") $ H.toHtml "Author: "
        H.input ! A.type_ (toValue "text") ! A.name (toValue "author")
      H.div $
        H.input ! A.type_ (toValue "submit") ! A.value (toValue "Add Note")
    H.h1 $ H.toHtml "Recent Notes"
    H.ul $ void $ mapM displayNote notes
          
displayNote :: Entity -> H.Html
displayNote note = fromMaybe (return ()) $ do
  text <- edmString "text" note
  author <- edmString "author" note
  return $ H.li $ do
    H.toHtml "'"
    H.toHtml text
    H.toHtml "'"
    H.i $ do 
      H.toHtml " says "
      H.toHtml author

routes :: [ServerPartT IO Response]
routes = [ getNotes, postNote ]

main :: IO ()
main = do 
  result <- createTableIfNecessary account "notes"
  case result of
    Left err -> putStrLn err
    Right _ -> simpleHTTP nullConf $ msum routes