shoes.cabal

name:                shoes
version:             0.1.0.0
license:             AllRightsReserved
author:              vi
maintainer:          me@vikramverma.com
build-type:          Simple
cabal-version:       >=1.10

executable shoes
  main-is: Shoes.hs
  other-extensions:    DeriveDataTypeable, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, TemplateHaskell, TypeFamilies
  build-depends:       base >=4.6 && <4.7, lens >=3.10 && <3.11, aeson >=0.7 && <0.8, base64-bytestring >=1.0 && <1.1, bytestring >=0.10 && <0.11, pureMD5 >=2.1 && <2.2, containers >=0.5 && <0.6, safecopy >=0.8 && <0.9, snap >=0.13 && <0.14, snap-core >=0.9 && <0.10, snap-server >=0.9 && <0.10, snaplet-acid-state >=0.2 && <0.3, directory >=1.2 && <1.3, blaze-html >=0.7 && <0.8, mtl >= 2.1 && <2.2, filepath >= 1.3 && < 1.4
  default-language:    Haskell2010

Shoes.hs

#!/usr/bin/env runhaskell

{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}

-- # [Task:](http://functionaljobs.com/jobs/8678-haskell-developer-at-zalora)
-- 
-- Write a FastCGI or HTTP server in Haskell that provides a restful API for
-- managing an inventory of shoes:
-- 
--  * POST new shoes as a JSON body, with attributes "description", "color",
--    "size", and "photo". The "photo" attribute should be a base-64 encoded
--    string representing a JPEG image (think "data URI"). For example,
-- 
--       { "description": "SADIE Faux Suede Heels with Bow"
--       , "color": "red"
--       , "size": "35"
--       , "photo": "/9j/4AAQSkZJRgABAQAAAQABAAD/2wBDAAMCAgMCAgMDAwMEAwMEBQgFBQQEBQoHBwYIDAoMDAsKCwsNDhIQDQ4RDgsLEBYQERMUFRUVDA8XGBYUGBIUFRT/2wBDAQMEBAUEBQkFBQkUDQsNFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBQUFBT/wAARCAA2ACUDASIAAhEBAxEB/8QAGwABAQACAwEAAAAAAAAAAAAAAAkGBwEFCAr/xAAxEAABAwMDAgUCBAcAAAAAAAABAgMEBQYRAAchCBIJEyIxUTJhF0GCkSMzQlJxgaH/xAAaAQABBQEAAAAAAAAAAAAAAAAAAgMEBQcG/8QAKxEAAQMDAgMHBQAAAAAAAAAAAQACAwQFERIhIjFxBhMyQVFhgaHB0eHx/9oADAMBAAIRAxEAPwCqClJQMqISPknXPGpgeKRvTNuC7U7a0+oPRaVTGG35jbKyA9KWAtPdj3CElGPglWs18N/ruO4UWHtTuJPIuyKnyaRVJCuai2kfyXFH3eSBwT9YGD6h6mhICcLpKqxVFLRw1bjnvBqx6D+YPQ+xVCuPjTj40xpjTq5tONNMaaEKSviRbJ1qxt3pd5+WqTb1xL8xmTyfKfCfWyo/keO5Pyk8fSceHno1RolYj1ykyHYEyM+mTGlMEpU08ghQUlQ9iDj/AJq3XiFW8mv9LtwKUgKXCmQZCCRkpJkttEj9LqtS3bsuVZN6XFt7c7PlS4z6h5CvoWsDlSPstHaoEe4xqvk4HEBbXaqxl5tbYp/HHt8AAA/UZ/aq10T9TUfqe2Zh1qQW2rpppEGuREcdr4HDoH5IcHqH5A9w/p1v/wDfUH+nPqCqnRrvy7Ukoen27KIi1enoIzJjE5S4gHjzEZ7h+pOQFHVtLD3YtHcyzIV123X4VSoMsJDctDwSErUQA2sHBQvJAKFYIJxjUuN+oLL7pQOo5yGjhPL8LLP300wTpp1Ui6K+bHo249qVG27hhmfR56AiRHDq2ioBQUMLQQpJCkgggg8anB4ou1kml3dQL8hxVR1ONCDKlMjAUpHLKyf7u3KT9ko1T3H21je4W3dB3StSbblyQG6jSpiO1xpfuPggjkEHkEcjSHsDhhXNpuLrZVsn5tGxHqDz+x6gL5/Kg63e1WpzNecDDaXAl2ayj+IGyecge/8Aof4B9tbAvna/8MaYmo27PcqNjTXEOImJX6mncHsRISDjux3dqx6VDPbg9yR7wvjwmLSqSlu2zdtWpKlZwxMSiQ2PsOEq/cnWvZvhLXfPhsQHNzWDT2HFOtsrgLUkKPurt80DP31BMMgIwdlpMfaW2RytqYTpd5gt8uozg/K9PeH1uBeO4uxDU+7JaaoyxKMal1IvIcekR0oTkOkKKu9CypHrCVYSD6shRa7/AKP+lxXSxZVWoi7nkXM7UpglrUqMIzTJCAnCG+9fJxyrPOE8DHLU9uQBlZhc5Yp6yWWHGlxyMDA39lvzA0wNNNKVYnGuONNNCEOmmmhC/9k="
--       }
-- 
--  * GET a shoe as an HTML page listing the shoe details, where the photo is
--    served as an <img> tag with "src" pointing to a path on the local filesystem
--    (i.e. the photo must be accessible as a local file, not as a data URI).
-- 
--  * GET a list of shoes as an HTML page with hyperlinks to all available shoes.

import Prelude hiding (lookup, writeFile, div)
import Control.Applicative ((<$>), (<*>), (<|>))
import Control.Lens (makeLenses, view)
import Control.Monad (join, mzero, forM_)
import Control.Monad.Reader (ask)
import Control.Monad.State (modify)
import Control.Monad.Trans (liftIO)
import Data.Aeson (Value(..), FromJSON(..), (.:), decode)
import Data.ByteString.Char8 (ByteString(..), pack, writeFile, readInt)
import Data.ByteString.Lazy (fromStrict)
import Data.Digest.Pure.MD5 (md5)
import Data.Map (maxViewWithKey, lookup, insert, Map, empty, toList)
import Data.Monoid (mempty)
import Data.SafeCopy (SafeCopy(..), safeGet, safePut, contain)
import Data.Typeable (Typeable(..))
import Snap (Handler, Snaplet, SnapletInit, makeSnaplet, nestSnaplet, addRoutes, snapletValue, serveSnaplet)
import Snap.Core (Method(..), method, readRequestBody, modifyResponse, getResponse, setResponseStatus, getParam, addHeader, writeLBS, writeBS, finishWith)
import Snap.Http.Server (defaultConfig)
import Snap.Snaplet.AcidState (Acid, HasAcid(..), Update, Query, makeAcidic, acidInit, query, update)
import Snap.Util.FileServe (serveDirectory)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>), (<.>))
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Text.Blaze.Html5 (toHtml, docTypeHtml, Html, body, img, ul, li, (!), ToMarkup(..), ToValue(..), a, div, toValue)
import Text.Blaze.Html5.Attributes (src, href)
import qualified Data.ByteString.Base64 as Base64 (decode)

-- TYPES ---------------------------------------------------------------

data Shoe = Shoe
  { desc   :: String
  , colour :: String
  , size   :: String
  , photo  :: FilePath
  } deriving (Typeable)

-- PERSISTENCE ---------------------------------------------------------

data Database = Database
  { shoes :: Map Int Shoe
  } deriving (Typeable)

instance SafeCopy Database where
  putCopy (Database shoes) = contain $ safePut shoes
  getCopy = contain $ Database <$> safeGet

instance SafeCopy Shoe where
  putCopy Shoe {..}  = contain $ do safePut desc; safePut colour; safePut size; safePut photo
  getCopy = contain $ Shoe <$> safeGet <*> safeGet <*> safeGet <*> safeGet 

insertShoe :: Shoe -> Update Database ()
insertShoe = modify . insertShoe'

insertShoe' :: Shoe -> Database -> Database
insertShoe' shoe (Database map) = Database map'
  where map' = insert (next map) shoe map
        next = maybe 0 (succ . fst . fst) . maxViewWithKey

lookupShoe :: Int -> Query Database (Maybe Shoe)
lookupShoe n = lookup n <$> indexShoes

indexShoes :: Query Database (Map Int Shoe)
indexShoes = shoes <$> ask

makeAcidic ''Database ['indexShoes, 'insertShoe, 'lookupShoe]

-- PARSING/JSON --------------------------------------------------------

instance FromJSON Shoe where
  parseJSON (Object o) = Shoe 
                     <$> o .: "description" 
                     <*> o .: "color" 
                     <*> o .: "size" 
                     <*> o .: "photo"
  parseJSON _ = mzero

-- HTTP/SNAP -----------------------------------------------------------

data Shoes = Shoes 
  { _acid :: Snaplet (Acid Database)
  }

makeLenses ''Shoes

instance HasAcid Shoes Database where
  getAcidStore = view $ acid . snapletValue

type Route = Handler Shoes Shoes ()

routes :: [(ByteString, Route)]
routes = 
  [ ("/shoes/",    handleIndex)
  , ("/shoes/:id", handleItem)
  , ("/static/",   serveDirectory "static")
  ]

handleIndex :: Route
handleIndex = method GET getIndex
          <|> method POST postIndex

getIndex :: Route
getIndex = query IndexShoes
       >>= writeHTML . showIndex

postIndex :: Route -- XXX:prettify while preserving readability
postIndex = decode <$> readRequestBody 1000000
        >>= \res -> case res of
          Just shoe -> liftIO (rewriteDataURI shoe) 
                   >>= maybe badRequest ((>>goodRequest) . update . InsertShoe)
          _ -> badRequest

handleItem :: Route
handleItem = do
  param <- getParam "id" 
  case join $ fst <$$> readInt <$> param of
    Just n -> query (LookupShoe n)
          >>= maybe notFound (writeHTML . showInfo)
    _ -> badRequest

rewriteDataURI :: Shoe -> IO (Maybe Shoe)
rewriteDataURI s@Shoe{..} = do
  result <- writeImage . pack $ photo
  return $ case result of
    Left _     -> Nothing
    Right file -> Just s{photo='/':file} -- / == Relative to site root.

writeImage :: ByteString -> IO (Either String String)
writeImage bs = case Base64.decode bs of
  Left err   -> return $ Left err
  Right file -> writeFile path file
             >> return (Right path)
  where path = "static" </> "images" </> hash bs <.> "jpg"
        hash = show . md5 . fromStrict

-- VIEWS --------------------------------------------------------------

showIndex :: Map Int Shoe -> Html
showIndex = document 
          . ul 
          . flip forM_ li 
          . map showIndexItem
          . toList

showIndexItem :: (Int, Shoe) -> Html
showIndexItem (index, shoe) = a ! href link $ text
  where link = toValue $ "/shoes/" ++ show index -- XXX: read from routes
        text = toMarkup $ desc shoe

showInfo :: Shoe -> Html
showInfo shoe = div $ do
  showImage shoe
  ul . sequence_ . map (showProp shoe) $ [desc, size, colour]

showProp :: ToMarkup a => Shoe -> (Shoe -> a) -> Html
showProp shoe prop = li . toHtml . prop $ shoe

showImage :: Shoe -> Html
showImage shoe = img ! src path
  where path = toValue . photo $ shoe

-- MAIN ---------------------------------------------------------------

snaplet :: SnapletInit Shoes Shoes
snaplet = makeSnaplet "shoes" mempty Nothing $ do
  db <- nestSnaplet mempty acid . acidInit $ Database empty
  addRoutes routes
  return $ Shoes db

main :: IO ()
main = createDirectoryIfMissing True "static/images"
    >> serveSnaplet defaultConfig snaplet

-- UTILITY ------------------------------------------------------------

(<$$>) :: (Functor f, Functor g) => (a -> b) -> g (f a) -> g (f b)
(<$$>) = fmap . fmap

document :: Html -> Html
document = docTypeHtml . body

isHTML :: Route
isHTML = modifyResponse $ addHeader "Content-Type" "text/html"

writeHTML :: Html -> Route
writeHTML = (isHTML >>) . writeLBS . renderHtml 

respond :: Int -> ByteString -> Route
respond code msg = modifyResponse (setResponseStatus code msg)
                >> writeBS msg
                >> getResponse 
               >>= finishWith

notFound :: Route
notFound = respond 404 "Not found!"

badRequest :: Route
badRequest = respond 400 "Bad request!"

goodRequest :: Route
goodRequest = respond 200 "OK!"