Skip to content

Instantly share code, notes, and snippets.

@fmap
Created February 10, 2014 15:36
Show Gist options
  • Save fmap/8918010 to your computer and use it in GitHub Desktop.
Save fmap/8918010 to your computer and use it in GitHub Desktop.
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
#!/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!"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment