Example.hs

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



import Control.Monad (when, liftM, join)

import           Data.List (sortBy)
import           Data.Ord  (comparing)
import Data.Maybe    (fromMaybe)
import           Data.Text (Text)
import           Yesod

import qualified Data.Text as T



import Data.Aeson
import Data.Aeson.Types


data Person = Person
    { personName :: Text
    , personAge  :: Int
    } deriving (Eq, Show)


people :: [Person]
people =
    [ Person "Miriam" 25
    , Person "Eliezer" 3
    , Person "Michael" 26
    , Person "Gavriella" 1
    ]

getFields :: Yesod m => HandlerT m IO (Maybe [Text])
getFields = splitFields <$> lookupGetParam "fields"
    where splitFields mfields =
            case mfields of
              Nothing -> Nothing
              Just "" -> Nothing
              -- Split the text, and strip it from spaces.
              Just val -> Just . fmap T.strip $ T.splitOn "," val

instance ToJSON Person where
  toJSON Person{..} = object $ defaultObj `mappend` metaData
    where
      defaultObj =
        [ "name" .= personName
        , "age"  .= personAge
        ]
      metaData =
        [ "_links" .= object
          [ "self" .= String ("selfy" :: Text)
          ]
        ]
      fields = getFields :: HandlerT App IO (Maybe [Text])


data App = App

mkYesod "App" [parseRoutes|
/ HomeR GET
/json HomeJsonR GET
|]

instance Yesod App

instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage


getHomeJsonR :: Handler Value
getHomeJsonR =
  return $ object ["data" .= people]

getHomeR :: Handler Html
getHomeR = do

  mfields <- getFields
  defaultLayout [whamlet|
    <div .wrapper>
      $maybe fields <- mfields
        Fields:
        <ul>
            $forall field <- fields
                <li>#{field}
      $nothing
        No fields found.
  |]

showPeople :: Widget
showPeople = do
    msort <- runInputGet $ iopt textField "sort"

    let people' =
            case msort of
                Just "name" -> sortBy (comparing personName) people
                Just "age"  -> sortBy (comparing personAge)  people
                _           -> people

    let font' =
            case msort of
                Just "name" -> "verdana" :: Text
                Just "age"  -> "arial" :: Text
                _           -> "times" :: Text
    toWidget [whamlet|
        <dl>
            $forall person <- people'
                <dt>#{personName person}
                <dd>#{show $ personAge person}
    |]

    toWidget [lucius| dl { font-family: #{font'} } |]

main :: IO ()
main = warp 3000 App