public
Created

JSON backend using Happstack

  • Download Gist
Main.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
 
module Main where
 
import qualified Data.ByteString.Lazy.Char8 as L
import Control.Monad.IO.Class (liftIO)
import Control.Monad (msum, mzero)
import Data.Data (Data, Typeable)
import Data.Maybe (fromJust)
import Data.Aeson
import Happstack.Server
import Happstack.Server.Types
import Control.Applicative ((<$>), (<*>))
 
main :: IO ()
main = simpleHTTP nullConf myApp
 
myPolicy :: BodyPolicy
myPolicy = (defaultBodyPolicy "/tmp/" 0 1000 1000)
 
myApp :: ServerPart Response
myApp = do decodeBody myPolicy
msum [ dir "unit" $ postUnit
, dir "public" $ fileServing
]
 
fileServing :: ServerPart Response
fileServing =
serveDirectory EnableBrowsing ["index.html"] "public/"
 
data Unit = Unit { x :: Int, y :: Int } deriving (Show, Eq, Data, Typeable)
 
instance FromJSON Unit where
parseJSON (Object v) = Unit <$>
v .: "x" <*>
v .: "y"
parseJSON _ = mzero
 
instance ToJSON Unit where
toJSON (Unit x y) = object ["x" .= x, "y" .= y]
 
getBody :: ServerPart L.ByteString
getBody = do
req <- askRq
body <- liftIO $ takeRequestBody req
case body of
Just rqbody -> return . unBody $ rqbody
Nothing -> return ""
 
postUnit :: ServerPart Response
postUnit = do
body <- getBody
case decode body :: Maybe Unit of
Just unit -> ok $ toResponse $ encode $ unit {x = x unit + 1 }
Nothing -> badRequest $ toResponse $ ("Could not parse" :: String)

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.