Dog Park Snaplet Tutorial
Henry Laxen March 15, 2013

This purpose of this document is two-fold. One is to help me remember what and why I did, and second, to provide to you, gentle reader, a complete and relative simple example of writing a web application using the wonderful Snap Framework in Haskell.

Background

Here at Lake Chapala we have a wonderful new dog park where we bring our big dobie baby, Athena, to blow off some steam. It is very handy to know in advance who is going or not going to the dog park, so I decided to create a small web app that lets people know.

Overview

One of the main goals was that I wanted everything to be as simple as possible, both for me as the administrator, and for the users who were not very computer literate. Thus I decided that:
  1. I would store the data in a format that would make it easy to edit in emacs.
  2. I would make authentication brain dead simple, and thus highly insecure
  3. As easy as I could think of to use the system, hence cookies and email
So with that as background, lets start at the bottom and look at the Types.

First we get the extensions and imports out of the way: 

«types imports»
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes  #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}


module DogPark.Types where
import Control.Monad.IO.Class ( MonadIO )
import Control.Monad.State.Class ( MonadState )
import Data.Text ( Text )
import Data.Time ( UTCTime )
import Data.ByteString.Char8 ( ByteString )
import qualified Data.Map as M ( empty )
import Data.Map ( Map )
import Data.Default ( Default(..) )
import Lens.Micro.Platform ( makeLenses )
import Snap.Snaplet.Heist ( Heist, SnapletISplice )
import Snap ( Handler, Snaplet )
import Snap.Snaplet.Session ( SessionManager )
import Data.IORef ( IORef )
import           Control.Exception.Lifted
One hint I can give you is after you have finished coding, run your module through ghc with the -ddump-minimal-imports option. If the import list is too long, I leave it out, but if it is small I use it so that I can remember what came from where.

At the very bottom is the Message type. The TooSoon message came about because sometimes users got confused or thought that their message wasn't sent, and went ahead and clicked on the message button again. I now detect that, and rather than spamming the users, tell the sender that his message has indeed been sent, and it is not necessary to send another. The timeout is 5 minutes. 

«types Message»
data Message = IAmGoing | IAmNotGoing | TooSoon | Custom Text | NoMessage
  deriving (Show, Read, Ord, Eq)

showMessage :: Message -> Text
showMessage IAmGoing    = "we are going to the dog park"
showMessage IAmNotGoing = "we are NOT going to the dog park"
showMessage TooSoon = "I have already notified everyone, don't worry"
showMessage NoMessage = "No Message"
showMessage (Custom b)  = b

instance Default Message where
  def = NoMessage
A dog has an id, a name, and perhaps a photo. If the photo is missing, I output the name instead. 
«types Dog»
type DogId = Int
data Dog = Dog {
    _dogId        :: DogId
  , _dogName      :: Text
  , _dogImage     :: Maybe Text }
  deriving (Ord, Eq)

showsDog :: Dog -> String -> String
showsDog (Dog a b c) =
  showString    "Dog "
  . shows a . (' ':) 
  . shows b . (' ':) 
  . shows c . ('\n':) 


readsDog :: String -> [(Dog,String)]
readsDog s =
  [ (Dog a b c , rest) |
        ("Dog", x1) <- lex s,
      (a, x2) <- reads x1,
      (b, x3) <- reads x2,
      (c, rest) <- reads x3
  ]
  
instance Show Dog where
  showsPrec _ = showsDog

instance Read Dog where     
  readsPrec _ = readsDog

instance Default Dog where
  def = Dog 0 "" Nothing
The owner field is a little more complicated. Some people have multiple email address, hence the list of Text for the email. Also, before the owner's first visit, the _ownerRecent field is Nothing, since he hasn't make any recent visits. The show and read instances make it nice for emacs. This and the Recent type are the only data that are stored. 
«types Owner»
type OwnerId = Int
data Owner = Owner {
    _ownerId         :: OwnerId
  , _ownerName       :: Text
  , _ownerImage      :: Maybe Text
  , _ownerEmail      :: [Text]
  , _ownerRemind     :: Bool -- True if wants daily reminder
  , _ownerWantsEmail :: Bool -- True if wants messages
  , _ownerRecent     :: Maybe Recent
  }  deriving (Ord, Eq)

showsOwner :: Owner -> String -> String
showsOwner (Owner a b c d e f g) =
  showString    "Owner "
  . shows a . (' ':) 
  . shows b . (' ':) 
  . shows c . (' ':) 
  . shows d . (' ':) 
  . shows e . (' ':) 
  . shows f . (' ':) 
  . shows g

readsOwner :: String -> [(Owner,String)]
readsOwner s =
  [ (Owner a b c d e f g, rest) |
        ("Owner", x1) <- lex s,
      (a, x2) <- reads x1,
      (b, x3) <- reads x2,
      (c, x4) <- reads x3,
      (d, x5) <- reads x4,
      (e, x6) <- reads x5,
      (f, x7) <- reads x6,
      (g, rest) <- reads x7
  ]
  
instance Show Owner where
  showsPrec _ = showsOwner

instance Read Owner where     
  readsPrec _ = readsOwner

instance Default Owner where
  def = Owner 0 "" Nothing [] False False Nothing
The HasId class is shared by owners and their dogs. It gives us a way to get from an id (Int) to name and Maybe Text (photo) of the object. This is handy for using the same code to disply button widgets and Text describing an owner or their dog. 
«types HasId»
class HasId a where
  theId :: a -> Int

instance HasId Dog where  
  theId = _dogId

instance HasId Owner where  
  theId = _ownerId

class HasId a  => HasButton a where  
  buttonName  :: a -> Text
  buttonImage :: a -> Maybe Text

instance HasButton Dog where
  buttonName    = _dogName
  buttonImage   = _dogImage

instance HasButton Owner where
  buttonName    = _ownerName
  buttonImage   = _ownerImage
People and the dogs travel in packs. Hence when an owner decides to come to the park, he may be accompanied by other owners, and some or all of his dogs. Hence the list fields in the Recent data type. 
«types Recent»
data Recent = Recent {
    _recentLoggedInOwner :: OwnerId
  , _recentOwnerIds      :: [OwnerId]
  , _recentDogIds        :: [DogId]
  , _recentTime          :: UTCTime  
  , _recentMessage       :: Message }
  deriving (Ord, Eq)

instance Default Recent where
  def = Recent 1 [] [] someTime NoMessage

someTime :: UTCTime
someTime = read "2013-01-01 00:00:00.000000 UTC" :: UTCTime

showsRecent :: Recent -> String -> String
showsRecent (Recent a b c d e ) =
  showString    "Recent "
  . shows a . (' ':) 
  . shows b . (' ':) 
  . shows c . (' ':) 
  . shows d . (' ':) 
  . shows e . ('\n':) 

readsRecent :: String -> [(Recent,String)]
readsRecent s =
  [ (Recent a b c d e , rest) |
      ("Recent", x1) <- lex s,
      (a, x2) <- reads x1,
      (b, x3) <- reads x2,
      (c, x4) <- reads x3,
      (d, x5) <- reads x4,
      (e, rest) <- reads x5
  ]

instance Show Recent where
  showsPrec _ = showsRecent

instance Read Recent where     
  readsPrec _ = readsRecent

type RecentVisits =  [Recent]
The first time I wrote this, I locked out owners who misidentified their dogs. This was to prevent spammers. Well, there weren't any spammers, but there were several frustrated owners, so I removed the lockout code. I should probably remove the corresponding data, but I'm leaving it here as a reminder. OwnersAndTheirDogs is a pair of lists that associates a list of owhers (who belong to the same family) with a list of dogs (the dogs they may be bringing to the dog park.) This list is maintained by me as part of the code. 
«types OwnersAndTheirDogs»
newtype OwnersAndTheirDogs = OwnersAndTheirDogs 
    { unOwnersAndTheirDogs :: ([OwnerId],[DogId]) } 
    deriving (Show, Read, Ord, Eq)

instance Default OwnersAndTheirDogs where
  def = OwnersAndTheirDogs ([],[])

newtype  LockoutMap = LockoutMap (Map ByteString UTCTime)

instance Default LockoutMap where
  def = LockoutMap M.empty
Everything stored permanently on disk goes here. 
«types Stored»
data Stored = Stored {
       _storedOwners     :: [Owner]
     , _storedDogs       :: [Dog]
     , _storedRelations  :: [OwnersAndTheirDogs]
  }   deriving (Show, Read, Ord, Eq)
Everything you need to know about an Owner, including his family and his dogs, referenced by an ownerId. 
«types AboutOwners»
data AboutOwners = AboutOwners {
    _ownersThis   :: Owner
  , _ownersFamily :: [Owner]
  , _ownersDogs   :: [Dog]
  }   deriving (Show, Read, Ord, Eq)
  
type OwnerMap = (Map OwnerId AboutOwners)
Everything the Snaplet needs to run. 
«types DogParkState»
data DogParkState = DogParkState {
       _dogParkHeist        :: Snaplet (Heist DogParkState) 
    ,  _dogParkSession      :: Snaplet SessionManager
    ,  _dogParkOwnerMap     :: IORef OwnerMap 
    ,  _dogParkStored       :: Stored  }
        
type DogParkData = ([Owner] , [Dog] , OwnerMap)
type DogParkHandler a = Snap.Handler DogParkState DogParkState a                   
type DogParkSplice    = SnapletISplice DogParkState
type DPS m a = (MonadIO m, MonadState DogParkState m) => m a
All the different errors that can occur when we process a reminder. The user is sent an encrypted link in an email message. In order for the link to be valid, it must decrypt property, not be expired, and contain a valid ownerId. 
«types RemindError»
data RemindError = ParameterMissingError |
                   URLDecryptionError |
                   URLReadError |
                   URLExpiredError  |
                   RemindError String

instance Exception RemindError where

instance Show RemindError where
  show ParameterMissingError = "The q parameter was missing"
  show URLDecryptionError = "URI was not properly decrypted"
  show URLReadError = "URI could not be read"
  show URLExpiredError = "The URI has expired"
  show (RemindError s) = s

type RemindMonad = Either RemindError

«types Lenses»
makeLenses ''Dog
makeLenses ''Owner
makeLenses ''Recent
makeLenses ''Stored
makeLenses ''AboutOwners
makeLenses ''DogParkState

Primitives

Starting now I'm leaving our the imports for the different packages. Some constants I use throughout the app. dogError is just a synonym for error. We warn the user if he reposts a message sooner than 5 minutes. By default, we display the ten most recent visits. 
«primitives Constants»

instance Default Stored where
  def = Stored [] [] []

tooSoonForAnotherMessage :: NominalDiffTime    
tooSoonForAnotherMessage = 60*5 -- 5 minutes

-- lockoutTime :: NominalDiffTime    
-- lockoutTime =  60*60 -- 1 hour

displayRecents :: Int
displayRecents = 10

dogError :: String -> a
dogError = error
relationMap creates a map from ownerIds to an OwnersAndTheirDogs which is then used to create an actual OwnerMap. lookupById is a helper function that looks up an id in a list that is an instance of HasId, which currently is just ownersList and dogsList, and returns the corresponding object. startOwnerMap takes a Stored, which is kept on disk and as an IORef, and uses it to create an OwnerMap. Once we have an OwnerMap, everything we need to know about an owner is quickly accessible. 
«primitives Maps»
relationMap :: [OwnersAndTheirDogs] -> Map OwnerId OwnersAndTheirDogs
relationMap = foldr foldOwners def 
  where
    foldOwners od@(OwnersAndTheirDogs (listOfOwners,_)) m =
      foldr (\a b -> M.insert a od b) m listOfOwners

lookupById :: HasId a => Int -> [a] -> Maybe a
lookupById key listWithKey  = lookup key zipWithKeys
  where
    ids = map theId listWithKey
    zipWithKeys = zip ids listWithKey


startOwnerMap :: Stored -> OwnerMap
startOwnerMap (Stored ownersList dogList relations) = foldr mkOne M.empty ownersList
  where
    family = mapMaybe (`lookupById` ownersList)
    dogs   = mapMaybe (`lookupById` dogList)
    mkOne owner oMap = case M.lookup (_ownerId owner) (relationMap relations)  of
      Nothing -> dogError $ "Expected to find " ++ show owner ++ " in OwnerMap"
      Just (OwnersAndTheirDogs (o,d)) ->
        M.insert (_ownerId owner) (AboutOwners owner (family o) (dogs d)) oMap
The dogMap never changes while the Snap app is running, since it can only be modified externally. Thus dogMap is pure. Often you want to convert from an id to the actual object. That is what dogFromMap and ownerFromMap do, however ownerFromMap needs access to the "current" version of the map, which could be changed by user input, hence it is impure. Oftentimes, we have already accessed the current ownerFromMap hence I added ownerFromMapPure. getAllOwners returns a list of all of the owners, which is read from the current ownerMap. Finally, getOwnerMap reads the IORef where the current ownerMap is stored and returns it. 
«primitives fromMap»
getDogMap ::  DogParkHandler  (Map DogId Dog)
getDogMap = do
  stored <- use dogParkStored 
  let dogs = stored ^. storedDogs
  return $ M.fromList $ zip (map _dogId dogs) dogs

dogFromMap :: DogId -> DogParkHandler Dog
dogFromMap dog = do 
  dMap <- getDogMap
  return $ fromJust (M.lookup dog dMap)

ownerFromMap :: OwnerId -> DogParkHandler Owner
ownerFromMap ownerid = fmap (`ownerFromMapPure` ownerid) getOwnerMap

ownerFromMapPure :: OwnerMap -> OwnerId -> Owner
ownerFromMapPure oMap ownerid  = fromJust (oMap ^.at ownerid) ^. ownersThis

dogFromMapPure :: (Map DogId Dog) -> DogId -> Dog
dogFromMapPure dMap dog = fromJust (M.lookup dog dMap)

getAllOwners :: DogParkHandler [Owner]
getAllOwners = do
  ownerMap <- getOwnerMap
  return $ map _ownersThis (M.elems ownerMap)

getOwnerMap :: DogParkHandler OwnerMap
getOwnerMap = do
  ioDogParkOwnerMap <- use dogParkOwnerMap
  liftIO $ readIORef ioDogParkOwnerMap       

getDogsFromOwnerMap :: OwnerMap -> [Dog]
getDogsFromOwnerMap = nub . concatMap  _ownersDogs . M.elems
A Recent only contains the ids of the family and their dogs, to make storage more compact. What we really want, however, is the corresponding owners and dogs. That is what setupRecent returns. getRecents returns a list of Recents, ordered by most recent visit. 
«primitives Recent»

setupRecent :: Recent -> DogParkHandler ([Owner], [Dog])
setupRecent recent = do
  oMap <- getOwnerMap
  dMap <- getDogMap
  let
    actualOwners = map (ownerFromMapPure oMap) (recent ^. recentOwnerIds)
    actualDogs = mapMaybe (`M.lookup` dMap) (recent ^. recentDogIds)
  return (actualOwners, actualDogs)

getRecents :: DogParkHandler [Recent]
getRecents = do
  om <- getOwnerMap
  let 
    recents = mapMaybe (view (ownersThis . ownerRecent)) (M.elems om)
    byTime a b = _recentTime b `compare`  _recentTime a
  return $  sortBy byTime recents
In several places we need to ask who is the family or the dogs of a particular owner. We also need to know if a particular dog belongs to a particular owner. 
«primitives Relations»

relationsOf :: Owner -> DogParkHandler AboutOwners
relationsOf owner = do
  om <- getOwnerMap
  return $ fromJust (om ^.at (owner ^. ownerId) )

familyOf :: Owner -> DogParkHandler [Owner]
familyOf owner = fmap (view ownersFamily) (relationsOf owner)

dogsOf :: Owner -> DogParkHandler [Dog]
dogsOf owner = fmap (view ownersDogs) (relationsOf owner)

namesOf :: HasButton a => [a] -> [Text]
namesOf = map buttonName

hasDog :: Owner -> DogId -> DogParkHandler Bool
hasDog owner dId = do
  theDogs <- dogsOf owner
  let ids = map (view dogId) theDogs
  return $  dId `elem`  ids
These are functions that manipulate the dog park data that is stored on disk. Since I manually add a new owner and their dogs to the data file, I need to merge that data with the exisiting data that may have been owner modified, namely the ownerWantsEmail and ownerRemind booleans, and the ownerRecent recent visit data. 
«primitives Stored»
-- mergeStored :: IO ()
-- mergeStored = do
--   (Stored storedOwnerList _ _) <- getStoredFile
--   let 
--     newOwnerList = map replaceVolatiles _ownersList
--     replaceVolatiles newOwner = 
--       let 
--         oldOwner = lookupById (newOwner ^. ownerId) storedOwnerList
--         updateVolatiles new old = new {
--             _ownerWantsEmail = _ownerWantsEmail old
--           , _ownerRemind  = _ownerRemind  old
--           , _ownerRecent = _ownerRecent old }
--       in maybe newOwner (updateVolatiles newOwner) oldOwner
--   let
--     newOwnerMap = startOwnerMap $ Stored newOwnerList _allDogs _ownersAndTheirDogs
--     (newDogs,newRelations) = (getDogsFromOwnerMap newOwnerMap, 
--                               nub $ getAllRelations newOwnerMap)
--   writeFile dogParkOwnerFile $ show newOwnerList
--   writeFile dogParkStaticFile $ show (newDogs,newRelations)
--   where
--     getAllRelations :: OwnerMap -> [OwnersAndTheirDogs]
--     getAllRelations oMap =
--       let
--         oneRelation aboutOwner = OwnersAndTheirDogs 
--           (  map _ownerId $ aboutOwner ^. ownersFamily
--            , map _dogId $ aboutOwner ^. ownersDogs)
--       in map oneRelation $ M.elems oMap

  
readFileWithLock :: Read a => FilePath -> IO a
readFileWithLock fileName =
  withLock fileName Shared Block $ 
    fmap read (System.IO.Strict.readFile fileName)

putFileWithLock :: Show a => FilePath -> a -> IO ()
putFileWithLock fileName theData = 
  withLock fileName Exclusive Block $ 
    writeFile fileName (show theData)

getOwnerList :: IO [Owner]
getOwnerList = readFileWithLock dogParkOwnerFile

getStoredFile :: IO Stored
getStoredFile = do
  ownerList <- getOwnerList
  (dogs,relations) <- readFileWithLock dogParkStaticFile
  return $ Stored ownerList dogs relations

initStoredStatic :: IO ()
initStoredStatic = do
  let d = def :: Stored
  writeFile dogParkStaticFile $ show (d ^. storedDogs , d ^. storedRelations)

initStored :: IO ()
initStored = do
  let d = def :: Stored
  writeFile dogParkOwnerFile $ show $ d ^. storedOwners
  initStoredStatic
These functions make debugging functions that need access to the Snaplets DogParkState much easier. dps sets up an initial DogParkState, and tdps runs a fuction that needs such a state and returns the result. 
«primitives DogParkState»

dps :: Stored -> IO DogParkState
dps stored = do 
  dpIO <- newIORef (startOwnerMap stored)
  return $ DogParkState undefined undefined dpIO stored

tdps :: Stored -> StateT DogParkState IO b -> IO b
tdps stored f = do
  initialState <- dps stored
  evalStateT f initialState
We (weakly) authenticate users using cookies. The authenticated user has an encrypted cooked that never expires and contains his ownerId. 
«cookies getKnownCookie»
knownCookieName :: ByteString
knownCookieName = "SanAntonioDogParkUser"

knownCookie :: ByteString -> Cookie
knownCookie x = 
  Cookie knownCookieName x Nothing Nothing (Just "/dogpark") False False

setKnownCookie :: (Show a, MonadSnap m, MonadIO m) => a -> m ()
setKnownCookie x = do
  key <- liftIO getDefaultKey
  val <- liftIO . encryptIO key . B8.pack . show $ x
  modifyResponse $ addResponseCookie (knownCookie val)

decryptCookie :: (Read b, MonadIO m) => Cookie -> m (Maybe b)
decryptCookie cookie = do
  key <- liftIO getDefaultKey
  return $ fmap (read . B8.unpack) . decrypt key . cookieValue $ cookie

getKnownCookie :: (MonadSnap m, MonadState DogParkState m) =>
     m (Maybe AboutOwners)
getKnownCookie = do 
  ownerMap <- getOwnerMap
  maybeCookieOwnerId <- runMaybeT $ do
    c <- MaybeT $ getCookie knownCookieName           -- do we have a known cookie?
    MaybeT $ decryptCookie c                         -- can we decrypt it?
  let result = maybe Nothing (`M.lookup` ownerMap)   -- does the owner exist?
  return $ result maybeCookieOwnerId
All of the splices used in the dogpark app are defined here.

o
Splice Action
ifKnown Process the children of this element if the user is known to us, ie has a known cookie
ifUnknown Process the children of this element if the user is unknown to us
owners return a list of clickable buttons, whose content is a small photo of the owner and whose value is the ownerId
dogs return a list of clickable buttons, whose content is a small photo of the dog and whose value is the dogId
showRecent returns a formatted list of the last ten visits
yourFamily returns English text of the people in your family
yourDogs returns English text of the dogs in your family
yourDogsBe conjugates "to be" depending on the number of dogs
yourDogsPlural adds and "s" if you have more than 1 dog
owner returns the name of this owner
checkBoxRemind returns a checkbox representing if the owner wants a daily reminder
checkBoxWantsEmail returns a checkbox representing if the owner wants to receive email notifications
ownersGoing returns a list of checkboxes for the owner's family. Owner should check the ones that will be going today.
dogsGoing returns a list of checkboxes for the owner's dogs. Owner should check the ones that will be going today.
ownerTiny returns a tiny photo of this owner
yourDogsTiny returns a list of tiny photos of this owner's dogs
everyone returns a list of checkboxes for each owner and their dogs
ownersHere returns and English list of the names of the owners
dogsHere returns and English list of the names of the dogs

«splices rest»

smallImgPath :: Text -> Text
smallImgPath  = T.append (T.pack dogParkImageUrl)

tinyImgPath :: Text -> Text
tinyImgPath  = T.append (T.pack dogParkImageUrlTiny)

makeImageButton :: HasButton a => a -> Template
makeImageButton x =
  [ X.Element  "button" [("value",tShow . theId $ x)
                         , ("name", "ownerDog")
                         , ("style", "-webkit-appearance:none;")
                         , ("title", tShow . buttonName $ x)
--                         , ("alt", tShow . buttonName $ x)
                         , ("type","submit")]
    [ maybe (X.TextNode (buttonName x)) 
            (\y -> X.Element "img" [("src" , smallImgPath y)] []) (buttonImage x) 
    ]
  ]

makeTinyImage :: HasButton a => a -> Template
makeTinyImage x =
  case buttonImage x of
    Nothing -> []
    Just y -> 
      [X.Element "img" [("src", tinyImgPath y), 
                        ("title",  buttonName  x)] []]

tinyImageHelper :: (HasButton a) => [a] -> DogParkSplice
tinyImageHelper = return . concatMap makeTinyImage                     
    
buttonSpliceHelper  :: (HasButton a) => [a] -> DogParkSplice
buttonSpliceHelper  = return . concatMap makeImageButton

ifKnownHelper :: Bool -> DogParkSplice
ifKnownHelper x = do
  cookie <- lift getKnownCookie
  node <- getParamNode
  return $ case cookie of
    Nothing -> if x then [] else childNodes node
    Just _ ->  if x then childNodes node else []

knownSplices :: Splices DogParkSplice 
knownSplices = do
    ("ifKnown"   ## ifKnownHelper True)
    ("ifUnknown" ## ifKnownHelper False) 

makeCheckBox :: HasButton a => Text -> Bool -> a -> Template
makeCheckBox name checked x  = 
  [X.Element "input" attributes []]
    where 
      attributes = 
        [
            ("type", "checkbox")
          , ("name", name)
          , ("value", tShow . theId $ x)
        ] ++ [("checked", "checked") | checked]  

makeNameCheckbox :: HasButton a => Text -> Bool -> a -> Template
makeNameCheckbox name checked x = 
  makeCheckBox name checked x ++ [X.TextNode (buttonName x)]

ownersGoingTemplate :: Owner -> DogParkHandler Template
ownersGoingTemplate owner = do
  owners <- familyOf owner
  let
    wentLastTime o = case o ^. ownerRecent of
      Nothing -> True
      Just x -> o ^. ownerId `elem` x ^. recentOwnerIds
    mkOwnersGoingTemplate = 
      [X.Element "br" [] [] ] ++ 
      [X.TextNode "People coming (or not) today are: " ] ++
      concatMap (\o -> makeNameCheckbox "ownersGoing" (wentLastTime o) o) owners
  return  mkOwnersGoingTemplate 

dogsGoingTemplate :: Owner -> DogParkHandler Template
dogsGoingTemplate owner  = do
  dogs <- dogsOf owner
  let
    wentLastTime d = case owner ^. ownerRecent of
      Nothing -> True
      Just x -> d ^. dogId `elem` x ^. recentDogIds
    mkDogsGoingTemplate = 
      [X.Element "br" [] [] ] ++ 
      [X.TextNode "Dogs coming (or not) today are: " ] ++
      concatMap (\d -> makeNameCheckbox "dogsGoing" (wentLastTime d) d) dogs
  return mkDogsGoingTemplate 

-- Yesterday,  Nancy said: Raven, I am going to the dog park
oneVisit :: UTCTime -> Recent -> DogParkHandler Text
oneVisit now recent  = do
  (recentOwners, recentDogs) <- setupRecent recent
  let 
    chapalaTime = fuzzyTime now (recent ^. recentTime)
    ownersText = englishList . namesOf $ recentOwners
    dogsText   = if null recentDogs then ""
                 else (englishList . namesOf $ recentDogs) `T.append` ","
  return $ T.intercalate " "
      [    chapalaTime
         , ownersText
         , "said:"
         , dogsText
         , showMessage (recent ^. recentMessage)
      ]

visitSplice :: DogParkHandler Template
visitSplice = do
  now <- liftIO getCurrentTime
  recentVisits <- fmap (take displayRecents) getRecents
  let 
    actualVisits = filter (not . messageIsNull) recentVisits
    noVisits = [X.TextNode "There haven't been any recent visits"]
    liElement :: Recent -> DogParkHandler X.Node
    liElement x = do
      v <- oneVisit now x
      return $ X.Element "li" [] [X.TextNode v]
  visitsTemplate <- do
    theVisits <- mapM liElement actualVisits
    return [X.Element "ol" [] theVisits]
  return $ if null actualVisits then noVisits else visitsTemplate
  
messageIsNull :: Recent -> Bool
messageIsNull recent = recent ^. recentMessage == Custom ""

conjugateBe :: [a] -> Text
conjugateBe l = if length l > 1 then "are" else "is"

standardPlural :: [a] -> Text
standardPlural l = if length l > 1 then "s" else ""

alwaysAvailableSplices :: DogParkHandler (Splices DogParkSplice)
alwaysAvailableSplices = do
  allOwners <- getAllOwners
  ownerMap <- getOwnerMap
  let dogs = getDogsFromOwnerMap ownerMap
  visits <- visitSplice
  return $ 
    knownSplices <> do
          ("owners" ## buttonSpliceHelper allOwners)
          ("dogs" ## buttonSpliceHelper dogs) 
          ("showRecent" ## return visits) 

splicesWhenAuthenticated ::  AboutOwners -> DogParkHandler (Splices DogParkSplice)
splicesWhenAuthenticated aboutOwner = do
  let
    thisOwner = aboutOwner ^. ownersThis
    checkBoxHelper name f = 
      return $ makeCheckBox name (thisOwner ^. f) thisOwner
  yourFamily <- familyOf thisOwner
  yourDogs <- dogsOf thisOwner
  return $ do
      ("yourFamily"         ## textSplice . englishList . namesOf $ yourFamily)
      ("yourDogs"           ## textSplice . englishList . namesOf $ yourDogs)
      ("yourDogsBe"         ## textSplice $ conjugateBe yourDogs)
      ("yourDogsPlural"     ## textSplice $ standardPlural yourDogs)
      ("owner"              ## textSplice (thisOwner ^. ownerName))
      ("checkBoxRemind"     ## checkBoxHelper "ownerRemind"   ownerRemind)
      ("checkBoxWantsEmail" ## checkBoxHelper "ownerWantsEmail" ownerWantsEmail)
      ("ownersGoing"        ## lift $ ownersGoingTemplate thisOwner) 
      ("dogsGoing"          ## lift $ dogsGoingTemplate thisOwner)
      ("ownerTiny"          ## tinyImageHelper [thisOwner])
      ("yourDogsTiny"       ## tinyImageHelper yourDogs)
      ("everyone"           ## lift $ everyoneTemplate) 

acknowledgmentTemplate  :: Text -> Splices DogParkSplice
acknowledgmentTemplate x = ("acknowledgment" ## return 
                  [ X.Element "p" [("class","note1")] [
                  X.TextNode x ]]
               )

acknowledgeChangesSplice ::  Owner -> Owner -> Splices DogParkSplice
acknowledgeChangesSplice old new  = 
  let
    isDifferent field msg = if new ^. field /= old ^. field then msg else ""
    wantsEmailChanged = isDifferent ownerWantsEmail wantsEmailChangedMsg
    wantsEmailChangedMsg = 
      if new ^. ownerWantsEmail then
        "You will now receive a notice when someone announces they are or aren't coming"
      else "Your announcement notices will stop, as of now"

    wantsReminderChanged = isDifferent ownerRemind wantsReminderChangedMsg
    wantsReminderChangedMsg = 
      if new ^. ownerRemind then
        "You will now receive a daily reminder about announcing your intentions"
      else "Your daily reminder notices will stop, as of now"
    bothMessages = [wantsEmailChanged, wantsReminderChanged]
    result = if concat bothMessages == ""
     then ["You didn't change anything, that's okay, just thought you'ld like to know"] 
       else map T.pack $ filter (not . null) bothMessages
  in acknowledgmentTemplate (englishList result)

acknowledgmentSplice :: [Owner] -> [Dog] -> Message -> Splices DogParkSplice
acknowledgmentSplice owners dogs message =
  let 
    peopleComing = englishList . namesOf $ owners
    dogsComing = if null dogs then "coming"
                 else "coming with " `T.append` (englishList . namesOf $ dogs)
    telling = " I'll tell everyone"
    isAre = conjugateBe owners
    coming = case message of
      IAmGoing    -> T.intercalate " " [telling,  peopleComing, isAre, dogsComing]
      IAmNotGoing -> T.intercalate " " [telling,  peopleComing, isAre, "not coming"]
      Custom msg  -> T.intercalate " " [telling, peopleComing,  "said", msg]
      TooSoon     -> T.intercalate " " ["Don't worry", peopleComing, 
                                       "I've already passed on your message"]
      NoMessage   -> "No Message"
    splices = acknowledgmentTemplate coming
  in splices

bulkSplice :: [Owner] -> [Dog] -> Splices DogParkSplice
bulkSplice owners dogs = do
   ("ownersHere" ## textSplice . englishList . namesOf $ owners)
   ("dogsHere"   ## textSplice . englishList . namesOf $ dogs)

staticSplices :: Maybe AboutOwners -> DogParkHandler (Splices DogParkSplice)
staticSplices aboutOwner = do
  let moreSplices =
        maybe (return mempty) splicesWhenAuthenticated aboutOwner
  liftM2 (<>) moreSplices alwaysAvailableSplices

everyoneTemplate :: DogParkHandler Template
everyoneTemplate = do
  stored <- use dogParkStored
  ownerMap <- getOwnerMap
  dogMap <- getDogMap
  let 
    relation :: OwnersAndTheirDogs -> ([Owner], [Dog])
    relation (OwnersAndTheirDogs  (ownerIds, dogIds)) =
      ( map (ownerFromMapPure ownerMap) ownerIds,
        map (dogFromMapPure dogMap) dogIds )
    template :: ([Owner], [Dog]) -> Template 
    template (owners, dogs) = 
      [X.Element "br" [] [] ] ++ 
      concatMap (makeNameCheckbox "ownersHere" False) owners ++
      [X.TextNode " : "] ++ 
      concatMap (makeNameCheckbox "dogsHere" False) dogs
    everyone = map (template . relation) (stored ^. storedRelations)
  return $ concat everyone
This module implements the daily reminder functionality. I use crontab to send everyone a daily reminder about visiting the dogpark if they wish to have such a reminder. The reminder (usually) looks like this:
Dear Henry,
This is your daily reminder to let people know about your plans.
Please click on the appropriate link below.
The last time Nadine and Henry came with Athena, Adonis, and Aphrodite.
Please click here if you are GOING.
Please click here if you are NOT GOING.
Hope to see you there.
Nadine and Henry

The query contains an encrypted tuple, consisting of the ownerId and the IAmGoing or IAmNotGoing message. 

«remind message»

reminderBody :: OwnerId -> DogParkHandler Text
reminderBody  oId = do
  oMap <- getOwnerMap
  url2 <- makeEncryptedLink oId "Please click here if you are GOING."     IAmGoing
  url3 <- makeEncryptedLink oId "Please click here if you are NOT GOING." IAmNotGoing
  let 
    Just aboutOwner = M.lookup oId oMap
    maybeRecent = aboutOwner ^. ownersThis . ownerRecent
  msg1 <- case maybeRecent of
    Nothing -> return  $ T.intercalate "\n" 
          [   "It seems you haven't been here before"
            , T.concat ["Please just visit the "
            , url1 "dogpark website"
            , " and make your selections."]
          ]
    Just recent -> do
      (owners, dogs) <- setupRecent recent
      return $  T.intercalate "\n" 
          [ theLastTime owners dogs
          , url2 
          , url3
          , T.concat [  "Otherwise just visit the "
                      , url1 "dogpark website"
                      , " and make your selections."
            ]
          ]
  return $ T.intercalate "\n" 
     [
         "Dear " `T.append` (aboutOwner ^. ownersThis . ownerName) `T.append` ","
       , "This is your daily reminder to let people know about your plans."
       , "Please click on the appropriate link below."
       , ""
       , msg1
       , "Hope to see you there."
       , "Nadine and Henry" 
     ]



makeEncryptedLink :: OwnerId -> Text -> Message -> DogParkHandler Text
makeEncryptedLink oId msg message = do
  now <- liftIO getCurrentTime
  let 
    expires = addUTCTime (24*60*60) now
    toEncrypt = show (oId,expires,message)
  key <- liftIO getDefaultKey
  val <- liftIO . encryptIO key . B8.pack $ toEncrypt
  let 
    Just parkUri = parseURI "http://www.nadineloveshenry.com/dogpark/run"
    q = importList [("q", B8.unpack val)]
    url = addToURI q parkUri
    link = "<a href=\"" ++ show url ++ "\">" ++ T.unpack msg ++ "</a>"
  return $ T.pack link

theLastTime :: [Owner] -> [Dog] -> Text
theLastTime owners dogs = T.intercalate " "
    [
      "The last time,"
      , englishList . namesOf $ owners
      , "came with"
      , englishList . namesOf $ dogs
    ] `T.append` "."
  
url1 :: Text -> Text
url1 = link
  where
    Just parkUri = parseURI "http://www.nadineloveshenry.com/dogpark/index"
    link txt= T.concat [
      "<a href=\""
      , tShow parkUri
      , "\">"
      , txt
      , "</a>" ]
A helper function that throws an error if the first argument is Nothing. Otherwise it executes its second argument and returns its result 
«remind nothingError»

  
nothingError :: MonadError e m => Maybe t -> e -> (t -> m a) -> m a
nothingError ma err f =
  case ma of
    Nothing -> throwError err
    Just x -> f x
Decryption can fail in many ways, and I want to distinguish between them.
  1. The "q" parameter could be missing from the url
  2. The value of the "q" parameter cannot be decrypted
  3. The value can be decrypted, but not read
  4. The value can be read, but has expired
«remind decrypt»

doDecrypt  :: UTCTime -> Key -> Maybe ByteString -> Either RemindError (Int,Message)
doDecrypt now key maybeValue =
  nothingError maybeValue ParameterMissingError (\v ->
  nothingError (decrypt key v) URLDecryptionError (\x -> do
    let 
      readIt :: Maybe (Int,UTCTime,Message)
      readIt = readMaybe (B8.unpack x) 
    nothingError readIt URLReadError (\(oId, expireTime, message) -> 
      if now > expireTime then throwError URLExpiredError
        else return (oId,message))))
  `catchError` Left


decryptReminder ::  MonadSnap m => m (Either RemindError (Int,Message))
decryptReminder = do
  now <- liftIO getCurrentTime
  q <- getParam "q"
  key <- liftIO getDefaultKey
  return $ doDecrypt now key q
The meat and potatoes of the app is here of course. I'll briefly describe what each of the routes is doing here.

index If the user is known (ie has a known cookie) he is presented with a form and invited to check the boxes of the people and dogs are are (or are not) visiting the dog park today. He can also construct a custom message. If the user is not known, a page full of photos of current owners is presented, and the user is asked to click on the photo of themself.
owner or changeOwner Same as index with an unknown owner. Owner photos are displayed and the user is asked to click on their photo.
runOwner The photos of all the dogs are presented, and the owner is asked to click on one of the photos of the dogs that belong to him.
runDog If the dog belongs to this owner, he is now authenticated and receives a known cookie. He is sent to a page that prompts him to send a message of whether or not he is coming to the dogpark. If the dog does not belong to this owner, he is sent to the lockout page, which now just tells him to select a different dog.
message Displays a list of the ten most recent visits, and asks the user to click on a button and tell others if they are going or not. This is the same as a successful runDog
sendMessage handles the sending of the message, the updating of the DogParkState, the logging of the visit, and sends the user to the index page with an acknowlegement that his message has been sent.
reload reloads the ownerMap from the file stored on disk. I have to run this if I update the owner and dog data via emacs
remind broadcasts a reminder message to all users who want a reminder. In order to prevent spammers, this handler requires that the url is sent from localhost
bulk I added this because some people just don't bother. When I get to the park, I can see show is there, and if I GET this url, I'm presented with a page full of checkboxes, ordered by families and their dogs. I can click on all the ones who are present, when i POST the result, and email is sent out to all the users letting them know who is already at the park.
run This is the url pointed to by the reminder message. If the "q" parameter is valid, it is as if the user pressed the IAmGoing or IAmNotGoing button after being authenticated. 

«snaplet routes»

instance HasHeist DogParkState where heistLens = subSnaplet dogParkHeist

dogParkInit :: SnapletInit DogParkState DogParkState
dogParkInit  =
  makeSnaplet "dogParkSnaplet"
              "An Snaplet for visitors to the Dog Park." Nothing $ do
    h  <- nestSnaplet "heist" dogParkHeist $ heistInit dogParkTemplates
    sm <- nestSnaplet "sessionmanager" dogParkSession $
           initCookieSessionManager siteKey "_dogParkCookies" Nothing Nothing
    stored <- liftIO getStoredFile
    let ownerMap = startOwnerMap stored
    ioRefDogParkOwnerMap <- liftIO $ newIORef ownerMap
    addRoutes
     [
         (""             , redirect "/dogpark/index")
       , ("index"        , simpleRender "index")
       , ("index.html"   , simpleRender "index")
       , ("owner"        , simpleRender "owners")
       , ("changeOwner"  , simpleRender "owners")
       , ("runOwner"     , handleRunOwner)
       , ("runDog"       , handleRunDog)
       , ("message"      , needsAuth handleMessage)
       , ("sendMessage"  , needsAuth handleSendMessage)
       , ("reload"       , handleReload)
       , ("lockout"      , simpleRender "lockout")
--       , ("dump"         , dumpHandler "dump")
       , ("remind"       , handleRemind)
       , ("bulk"         , method GET $ needsAuth (\_ -> simpleRender "bulk"))
       , ("bulk"         , method POST $ needsAuth handleBulk)
       , ("run"          , handleRun)
--       , ("test"         , simpleRender "test")

     ]
    return $ DogParkState h sm ioRefDogParkOwnerMap stored
All output to be rendered passes through renderDogs. It takes three arguments. If the owner is authorized, the first argument is all the info about this particular owner. The second argument is the name of the template to render. The third argument is a list of any additional splices to attach before doing the rendering. Ususally this is null or an acknowledgement splice. simpleRender just takes the template name as its arguemnt. 
«snaplet render»
renderDogs  :: Maybe AboutOwners ->
               ByteString ->
               Splices DogParkSplice -> --[(Text, DogParkSplice)] ->
               DogParkHandler ()
renderDogs maybeAboutOwner templatePath addedSplices = do
  splices <-  staticSplices maybeAboutOwner
  renderWithSplices templatePath (splices <> addedSplices)

simpleRender :: ByteString -> DogParkHandler ()
simpleRender templateName  = do
  cookie <- getKnownCookie
  renderDogs cookie templateName mempty
needsAuth is added in the routing whenever the handler should only be run once the user is authenticated. If the user isn't autenticated, it redirects to index. 
«snaplet auth»
noAuthRedirect :: MonadSnap m => m a
noAuthRedirect = redirect "index"

-- Only run the handler if the user is authorized
-- setup the stored  lens before calling the handler
-- needsAuth :: DogParkHandler () -> DogParkHandler ()
needsAuth :: (AboutOwners -> DogParkHandler () ) -> DogParkHandler ()
needsAuth handler = do
  aboutOwner <- getKnownCookie
  maybe noAuthRedirect handler aboutOwner
Read and write session data, and return an error if we get a Nothing expecting a Just. 
«snaplet session»
setDogSession :: Text -> Text -> DogParkHandler ()
setDogSession key theValue =
  with dogParkSession $ setInSession key theValue >> commitSession

getDogSession :: Read a => Text -> DogParkHandler a
getDogSession key = with dogParkSession $ do
  mValue <- getFromSession key
  maybe (dogError "No such key in session") (return . tRead) mValue

maybeDogError :: Maybe a -> String -> (a -> b) -> b
maybeDogError maybeA msg f = maybe (dogError msg) f maybeA
Here is where we authenticate an owner. handleRunOwner gets the ownerDog parameter from the request, and makes sure the owner exists. It then stores the owner id in the session cookie and renders the photos of the dogs. handleRunDog checks that the dog really belongs to the owner saved in the session. If he does, he is now authenticated, and receives a known cookie. He is then redirected to the message page. If not, then he is redirected to a lockout screen. 
«snaplet authenticate»
handleRunOwner :: DogParkHandler ()
handleRunOwner = do
  maybeOwnerId <- getParam "ownerDog"
  ownerMap <- getOwnerMap
  maybeDogError maybeOwnerId "No owner parameter found" (\x -> do
      let
        thisOwnerId = readUtf8 x :: OwnerId
        maybeOwner = M.lookup thisOwnerId ownerMap
      maybeDogError maybeOwner "Owner not found in owner list" (\aboutOwner -> do
        setDogSession "owner" (tShow thisOwnerId)
        renderDogs Nothing "dogs" $ stringSplices [("owner", aboutOwner ^. ownersThis . ownerName)]))

handleRunDog :: DogParkHandler ()
handleRunDog = do
  maybeDogParam <- getParam "ownerDog"
  ownerMap <- getOwnerMap
  maybeDogError maybeDogParam "No dog parameter found" (\dogParam -> do
      cookieOwnerId <- getDogSession "owner"
      let
        maybeAboutOwner = M.lookup cookieOwnerId ownerMap
      maybeDogError maybeAboutOwner
        "owner exists in owners but not in ownerMap"
        (\aboutOwner -> do
            let thisOwner = aboutOwner ^. ownersThis
                thisDog = readUtf8 dogParam
            thisIsTheDogsOwner <- hasDog thisOwner thisDog
            if  thisIsTheDogsOwner then do
                setKnownCookie cookieOwnerId
                redirect "message"
              else redirect "lockout"))
The message we receive is either a standard message or a custom message, but not both. We first check for a standard message, then for a custom. The sanitizeBalance function makes sure the text returned in a custom message isn't malicious. The message sending handler is a little more complicated. It sets up a Recent object based on what the user returned, and also looks for any changes in the user's preferences, about receiving reminders and notifications. The handleSendMessageCommon is shared with the handleRun code when the user clicks on a reminder message. It handles setting up the acknowledgment splice, updating any modified user preferences, notifying the other users, and adding this visit to the visit log. 
«snaplet message»
handleMessage :: t -> DogParkHandler ()
handleMessage _ = simpleRender "message"

getMessage :: MonadSnap m => m Message
getMessage = do
  standard <- getParam "standardMessage"
  custom <- getParam "Custom"
  return $ firstJust standard custom
  where
    firstJust (Just x) _ = read . B8.unpack  $ x
    firstJust _ (Just y) = Custom . sanitizeBalance . decodeUtf8 $ y
    firstJust _ _ = NoMessage

handleSendMessage  :: AboutOwners -> DogParkHandler ()
handleSendMessage aboutOwner = do
  params <- getParams
  message <- getMessage
  now <- liftIO getCurrentTime
  let
    anyoneGoing  = M.lookup "ownersGoing" params
    anydogsGoing = M.lookup "dogsGoing"  params
    thisOwnerWantsEmail = isJust . M.lookup "ownerWantsEmail" $ params
    thisOwnerRemind  = isJust . M.lookup "ownerRemind"  $ params
    readInts = maybe [] (map readUtf8)
    [ownersGoingId, dogsGoingId] = map readInts [anyoneGoing, anydogsGoing]
    recent = Recent (aboutOwner ^. ownersThis . ownerId)
                        ownersGoingId
                        dogsGoingId
                        now
                        message
  handleSendMessageCommon aboutOwner thisOwnerRemind thisOwnerWantsEmail (Just recent)

handleSendMessageCommon :: AboutOwners -> Bool -> Bool -> Maybe Recent
     -> DogParkHandler ()
handleSendMessageCommon  aboutOwner newOwnerRemind newOwnerWantsEmail maybeRecent = do
  now <- liftIO getCurrentTime
  dogMap <- getDogMap
  case maybeRecent of
    Nothing -> error "User trying to send message with Nothing for recent"
    Just recent -> do
      let
        dogsGoing = map (dogFromMapPure dogMap) (recent ^. recentDogIds)
        message = recent ^. recentMessage
      ownersGoing <- mapM  ownerFromMap (recent ^. recentOwnerIds)
      when (message == NoMessage) $ redirect "index"
      let
        newRecent = recent { _recentTime = now }
        timeIsTooSoon t =
          addUTCTime tooSoonForAnotherMessage (t ^. recentTime ) > now
        tooSoon = maybe False
            (\t -> timeIsTooSoon t &&  (not . messageIsNull $ t))
                  (aboutOwner ^. ownersThis . ownerRecent)
      if tooSoon then do
        let acknowledgment = acknowledgmentSplice ownersGoing [] TooSoon
        renderDogs (Just aboutOwner) "index" acknowledgment
        else do
          let acknowledgment = acknowledgmentSplice ownersGoing dogsGoing message
          newAboutOwner <- updateStored newRecent newOwnerRemind newOwnerWantsEmail
          if messageIsNull newRecent then
            renderDogs (Just newAboutOwner) "index"
              (acknowledgeChangesSplice
                (aboutOwner ^. ownersThis) (newAboutOwner ^. ownersThis))
            else do
              renderDogs (Just newAboutOwner) "index" acknowledgment
              notifyUsersAboutRecent newRecent
              liftIO $ addToVisitLog newRecent

addToVisitLog :: Recent -> IO ()
addToVisitLog  = appendFile dogParkVisitsFile . show
allEmails gathers up all the email addresses of people who want email notifications and whose email address is not null. It returns a list of "To" addresses. mockEmail is used for debugging or aliased to email, which sends an email to the user. 
«snaplet emails»

allEmails :: DogParkHandler [String]
allEmails =
  nub . map (T.unpack . T.intercalate ", " . _ownerEmail) .
       filter emailWanted <$> getAllOwners
  where
    emailWanted :: Owner -> Bool
    emailWanted x = ( not . null $ (x ^. ownerEmail)) && (x ^. ownerWantsEmail)

-- mockEmail :: String -> String -> String -> String -> IO ()
-- mockEmail _to _from subject body =
--   appendFile "/tmp/mockEmails.txt" $
--     unlines [_to,_from,subject,body]

-- mockEmail :: Text -> Text -> Text -> Text -> Text -> IO ()
-- mockEmail = emai
updateStored handles all the updating needed when a new visitor announces his intentions, or updates his preferences. It runs through the list of all the owners, and replaces the changed data for the owner matching this one. It then writes the new file to disk, and updates the IORef holding the ownerMap to reflect the changes. 
«snaplet updateStored»
updateStored :: Recent -> Bool -> Bool -> DogParkHandler AboutOwners
updateStored newRecent newRemind newWantsEmail = do
  allOwners <- getAllOwners
  Stored _ dogs relations <- liftIO getStoredFile
  let
    replaceIf oid owner =
      if oid /= owner ^. ownerId then owner else
        owner {   _ownerWantsEmail = newWantsEmail
                , _ownerRemind  = newRemind
                , _ownerRecent = Just newRecent }
    thisId = newRecent ^. recentLoggedInOwner
    newOwnerList = map (replaceIf thisId) allOwners
    newOwnerMap = startOwnerMap $ Stored newOwnerList dogs relations
  liftIO $ writeFileWithLock dogParkOwnerFile newOwnerList
  dpo <- use dogParkOwnerMap
  liftIO $ atomicWriteIORef dpo newOwnerMap
  return . fromJust . M.lookup thisId $ newOwnerMap
notifyUsersAboutRecent construct the brief message about the new visit, and sends it out to the users who want to know. The real info is contained in the subject, so it is easy for them to see at a glance what is going on. 
«snaplet notifyUsersAboutRecent»

notifyUsersAboutRecent :: Recent -> DogParkHandler ()
notifyUsersAboutRecent newRecent = do
  now <- liftIO getCurrentTime
  message <- oneVisit now newRecent
  emails <- allEmails
  forM_  emails  (\e ->
    liftIO $  email
      (T.pack e)
      myEmail
      message
      "<a href=\"http://www.nadineloveshenry.com/dogpark/index\"> Hope they will see you there!</a>"
      ""
    )
Since I can externally update the owner file, I need to notify the Snaplet when this has happened. This function handles rereading the data and setting up the new ownerMap. 
«snaplet handleReload»
handleReload :: DogParkHandler ()
handleReload = do
  stored <- liftIO getStoredFile
  let newOwnerMap = startOwnerMap stored
  dpo <- use dogParkOwnerMap
  liftIO $ atomicWriteIORef dpo newOwnerMap
  dogParkStored .= stored
  writeText "Data reloaded from disk"
The remind handler can only be called by localhost, and send out a reminder email to all users who have checked the ownerRemind checkbox. The actual reminder text is created in the DogPark.Remind module. 
«snaplet reminders»

remindUsers  :: [Owner] -> DogParkHandler ()
remindUsers allOwners = do
  let
    ownersWhoWantReminders = filter emailWanted allOwners
    emailWanted :: Owner -> Bool
    emailWanted x = x ^. ownerEmail /= [] && (x ^. ownerRemind)
  forM_ ownersWhoWantReminders (\o -> do
    message <- reminderBody (o ^. ownerId)
    liftIO $ email
      (T.intercalate ", " $ o ^. ownerEmail)
      myEmail
      "Your Daily Dogpark Reminder"
      ""
      message
    )

handleRemind :: DogParkHandler ()
handleRemind = do
  req <- getRequest
  if rqServerAddr req /= "127.0.0.1" then
    error "handleRemind: Must be accessed via localhost"
    else do
      allOwners <- getAllOwners
      remindUsers allOwners
      writeText "Owners have been reminded"
handleRun is called when the user clicks on his reminder email message. If the url is valid, others are notified about his intentions and the index page is rendered reflecting this user's new input. 
«snaplet handleRun»
handleRun :: DogParkHandler ()
handleRun = do
  result <- decryptReminder
  case  result of
    Left err -> renderDogs Nothing "index" $ stringSplices [("acknowledgment", tShow err)]
    Right (oId, message) -> do
      ownerMap <- getOwnerMap
      let
        Just aboutOwner = M.lookup oId ownerMap
        Owner _ _ _ _ remind wantsEmail (Just recent)  = aboutOwner ^. ownersThis
        newRecent =  recentMessage .~ message $ recent
      setKnownCookie oId
      handleSendMessageCommon aboutOwner remind wantsEmail (Just newRecent)
These functions handle notifying users about one or more families who are currently at the park. The owners and the dogs are returned as a space seperated list of numbers represending the ownerId and dogId respectively. getIntParams parse these and returns them as Ints. bulkMessage takes a list of owners and dogs, and returns text nameing them. Then bulkNotify is used to send out the emails to people who want notifications. 
«snaplet bulk»

getIntParams :: MonadSnap m => ByteString -> m [Int]
getIntParams bs = do
  mbParam <- getParam bs
  let param = maybe (error "getIntParams got Nothing") B8.unpack mbParam
  return $ mapMaybe readMaybe . words  $ param

handleBulk :: AboutOwners -> DogParkHandler ()
handleBulk _ = do
  ownersGoingIds <- getIntParams "ownersHere"
  dogsGoingIds   <- getIntParams "dogsHere"
  ownerMap <- getOwnerMap
  dogMap <- getDogMap
  let
    owners = map (ownerFromMapPure ownerMap)  ownersGoingIds
    dogs = map (dogFromMapPure dogMap) dogsGoingIds
  message <- bulkMessage  owners dogs
  writeText message
  bulkNotify owners dogs

bulkNotify  :: [Owner] -> [Dog] -> DogParkHandler ()
bulkNotify owners dogs = do
  message <- bulkMessage owners dogs
  emails <- allEmails
  forM_  emails  (\e ->
    liftIO $  email
      (T.pack e)
      myEmail
      "Who is at the dog park now?"
      message
      ""
    )

bulkMessage ::  MonadIO m => [Owner] -> [Dog] -> m Text
bulkMessage owners dogs = do
  now <- liftIO getCurrentTime
  let
    peopleHere = englishList . namesOf $ owners
    dogsHere = englishList . namesOf $ dogs
  return $ T.intercalate " "
    [   "At"
      , formatChapalaTime now `T.append` ","
      , "the people here are:"
      , peopleHere `T.append` ".\n"
      , "The dogs here are:"
      , dogsHere `T.append` ".\n"
    ]

stringSplices :: [(Text, Text)] -> Splices (SnapletISplice b)
stringSplices = mconcat . map stringToSplice
  where
    stringToSplice (t1,t2) = t1 ## textSplice t2


«main»

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoMonomorphismRestriction #-}


import Snap.Test
import Snap.Core
import Snap.Snaplet
import qualified Data.Map as M
import qualified Data.Text as T
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8          as S
import Snap.Http.Server.Config
import Lens.Micro.Platform (makeLenses)
import Snap.Util.FileServe (serveDirectory)

import DogPark.Snaplet
import DogPark.Types
import DogPark.Splices
import Paths
import Web.ClientSession
import DogPark.Cookies
import qualified Data.ByteString.Char8 as B8
import Data.ByteString.Char8 ( ByteString )
import qualified Text.XmlHtml as X
import Blaze.ByteString.Builder


data AppState = AppState
  {     _dogPark      :: Snaplet DogParkState
  }
makeLenses ''AppState

appSnaplet :: SnapletInit b AppState
appSnaplet  = 
    makeSnaplet "nlh" "Nadine Loves Henry." Nothing $ do  
    d <- embedSnaplet "dogpark" dogPark dogParkInit
    addRoutes [ ("static", serveDirectory staticRoot) ]
    return $ AppState d


main = serveSnaplet defaultConfig appSnaplet

Please note, I left out some functions that I reuse frequently, which are in a module called Common. These aren't specific to this application, but are available in the tar archive if you want to look at them.

Quote of the day:
What to do in case of an emergency: 1. Pick up your hat. 2. Grab your coat. 3. Leave your worries on the doorstep. 4. Direct your feet to the sunny side of the street.
Unknown

Sitemap
Go up to Haskell Go up to Home Page of Nadine Loves Henry
Go back to Nadine and Henry's Calcudoku Solver