Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Michael Snoyman October 07, 2012
file 61 lines (50 sloc) 1.796 kb
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 56 57 58 59 60
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables, GeneralizedNewtypeDeriving, RecordWildCards #-}
module Main (main) where

import Yesod
import Yesod.Static
import Yesod.Angular
import Data.IORef
import Data.Text (pack)
import Data.Map (Map)
import qualified Data.Map as Map
import Types

data App = App
    { getStatic :: Static
    , ipeople :: IORef (Map PersonId Person)
    , nextId :: IORef Int
    }

mkYesod "App" [parseRoutes|
/ HomeR
/static StaticR Static getStatic
|]

instance Yesod App
instance YesodAngular App where
    urlAngularJs _ = Left $ StaticR $ StaticRoute ["angular", "angular.min.js"] []

type Angular = GAngular App App ()

handleHomeR :: Handler RepHtml
handleHomeR = runAngular $ do
    cmdGetPeople <- addCommand $ \() -> do
        people' <- getYesod >>= liftIO . readIORef . ipeople
        return $ map (\(pid, Person name _) -> PersonSummary pid name) $ Map.toList people'
    $(addCtrl "/people" "people")

    cmdPersonDetail <- addCommand $ \(Singleton pid) -> do
        app <- getYesod
        m <- liftIO $ readIORef $ ipeople app
        case Map.lookup pid m of
            Nothing -> notFound
            Just p -> return p
    $(addCtrl "/people/:personId" "person-detail")

    cmdAddPerson <- addCommand $ \p -> do
        app <- getYesod
        i <- fmap (PersonId . pack . show) $ liftIO $ atomicModifyIORef (nextId app) $ \i -> (i + 1, i + 1)
        () <- liftIO $ atomicModifyIORef (ipeople app) $ \m ->
            (Map.insert i p m, ())
        return $ Singleton i
    $(addCtrl "/add-person" "add-person")

    setDefaultRoute "/people"

main :: IO ()
main = do
    s <- static "static"
    p <- newIORef Map.empty
    ni <- newIORef 1
    warpDebug 3000 $ App s p ni
Something went wrong with that request. Please try again.