Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: b174e544c0
Fetching contributors…

Cannot retrieve contributors at this time

file 199 lines (154 sloc) 6.934 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 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
module Handler.Root where

import Control.Applicative
import Control.Monad
import Data.List (groupBy, partition, sortBy)
import Data.Monoid
import Data.Maybe (fromJust)
import Data.Text (Text, pack)
import Data.Text.Read
import Data.Time
import Database.Persist.GenericSql.Raw (SqlPersist)
import Text.Blaze (ToHtml)
import Yesod.Auth (maybeAuthId)
import Yesod.Handler
import Foundation


instance ToHtml a => ToHtml (Maybe a) where
  toHtml = maybe "" toHtml


redirectTemporary :: HasReps a => YesodoroRoute -> Handler a
redirectTemporary = redirect RedirectTemporary


-- This is a handler function for the GET request method on the RootR
-- resource pattern. All of your resource patterns are defined in
-- config/routes
--
-- The majority of the code you will write in Yesod lives in these handler
-- functions. You can spread them across multiple files if you are so
-- inclined, or create a single monolithic file.
getRootR :: Handler RepHtml
getRootR = maybeAuthId >>= getRootR' where
  getRootR' :: Maybe UserId -> Handler RepHtml
  getRootR' Nothing = defaultLayout $ do
        setTitle "yesodoro"
        addWidget $(widgetFile "homepage")
  getRootR' (Just _) = redirectTemporary TasksR


authed :: HasReps a => (UserId -> Handler a) -> Handler a
authed handler = maybeAuthId >>= maybe (redirectTemporary RootR) handler


authedTask :: HasReps a => ((TaskId, Task) -> Handler a) -> TaskId -> Handler a
authedTask handler taskId = authed (\userId -> do
    maybeAuthedTask <- runDB $ selectFirst [TaskId ==. taskId, TaskUser ==. userId] []
    case maybeAuthedTask of
      Just task -> handler task
      Nothing -> redirectTemporary TasksR)



getTasksR :: Handler RepHtml
getTasksR = authed (\userId -> do
  tasks <- runDB $ userTasks userId

  estimates <- runDB $ mapM (taskEstimates . fst) tasks
  let tasksEstimates :: [(TaskId, (Task, [(EstimateId, Estimate)]))]
      tasksEstimates = (map fst tasks) `zip` ((map snd tasks) `zip` estimates)

  timeZone <- liftIO getCurrentTimeZone
  now <- liftIO getCurrentTime
  let taskTodoToday :: Task -> Bool
      taskTodoToday = taskTodo timeZone now
      taskOverdueToday :: Task -> Bool
      taskOverdueToday = taskOverdue timeZone now
      taskDueClass :: Task -> Maybe String
      taskDueClass task | taskOverdueToday task = Just "overdue"
                        | otherwise = Nothing

  let (unsortedDone, pending) = partition (taskDone . fst . snd) tasksEstimates
  let done = reverse $ sortBy (compareBy $ taskDoneAt . fst . snd) unsortedDone
  let (unsortedTodo, unsortedLater) = partition (taskTodoToday . fst . snd) pending
  let todo = sortBy (compareBy $ taskOrder . fst . snd) unsortedTodo
  let later = sortBy (compareBy $ taskOrder . fst . snd) unsortedLater

  let doneByDay = groupByEq (fromJust . taskDoneDay timeZone . fst . snd) done
  ((_, taskWidget), enctype) <- generateFormPost taskForm
  defaultLayout $ do
      setTitle "tasks"
      addWidget $(widgetFile "tasks")) where

  userTasks userId = selectList [TaskUser ==. userId] [Asc TaskScheduledFor, Desc TaskDoneAt] -- must specify sorts backwards...
  taskEstimates taskId = selectList [EstimateTask ==. taskId] []
  taskTr taskTodoToday taskDueClass (taskId, (task, estimates)) = $(widgetFile "tasks/task-tr")
  estimatedRemaining :: (Task, [(EstimateId, Estimate)]) -> Int
  estimatedRemaining (_, []) = 0
  estimatedRemaining (task, ((_, estimate) : _)) = (estimatePomos estimate - taskPomos task) `max` 0


oneButton :: Text -> YesodoroRoute -> Widget
oneButton label route = [whamlet|
  <form method=POST action=@{route}
    <button>#{label}
|]

taskForm :: Html -> Form Yesodoro Yesodoro (FormResult NewTask, Widget)
taskForm = renderDivs $ NewTask <$> areq textField "Title" Nothing

postTasksR :: Handler RepHtml
postTasksR = authed (\userId -> do
  ((result, taskWidget), _) <- runFormPost taskForm
  case result of
    FormSuccess task -> do
      runDB $ createTaskAtBottom userId task
      redirectTemporary TasksR
    _ -> undefined) -- TODO


postCompleteTaskR :: TaskId -> Handler RepHtml
postCompleteTaskR = authedTask (\(taskId, _) -> do
  now <- liftIO getCurrentTime
  updateAndRedirectR TasksR [TaskDoneAt =. Just now] taskId)

postRestartTaskR :: TaskId -> Handler RepHtml
postRestartTaskR = updateAndRedirectR TasksR [TaskDoneAt =. Nothing]

updateAndRedirectR :: HasReps a => YesodoroRoute -> [Update Task] -> TaskId -> Handler a
updateAndRedirectR route updates = authedTask (\(taskId, _) -> do
  runDB $ update taskId updates
  redirectTemporary route)

setTaskDonenessRoute :: (TaskId, Task) -> YesodoroRoute
setTaskDonenessRoute (taskId, task) = route taskId
  where route | taskDone task = RestartTaskR
              | otherwise = CompleteTaskR

setTaskDonenessButton :: TaskId -> Task -> Widget
setTaskDonenessButton taskId task = oneButton action (route taskId)
  where action = taskActionName task
        route | taskDone task = RestartTaskR
              | otherwise = CompleteTaskR

postDeleteTaskR :: TaskId -> Handler RepHtml
postDeleteTaskR = authedTask (\(taskId, _) -> do
  runDB $ deleteWhere [EstimateTask ==. taskId]
  runDB $ delete taskId
  redirectTemporary TasksR)

postTaskAddPomoR :: TaskId -> Handler RepHtml
postTaskAddPomoR = updateAndRedirectR TasksR [TaskPomos +=. 1]

postTaskAddEstimateR :: TaskId -> Handler RepHtml
postTaskAddEstimateR = authedTask (\(taskId, _) -> do
  pomosParam <- lookupPostParam "pomos"
  let pomos = do
      param <- maybeToEither "no pomos" $ pomosParam
      (num, _) <- decimal param
      return num
  case pomos of
    (Right numPomos) -> do
      runDB $ insert $ Estimate taskId numPomos
      redirectTemporary TasksR
    Left msg -> error msg) -- TODO

maybeToEither :: String -> Maybe a -> Either String a
maybeToEither msg Nothing = Left msg
maybeToEither _ (Just v) = Right v


eqUnder :: Eq b => (a -> b) -> a -> a -> Bool
eqUnder f a b = f a == f b

groupByEq :: Eq g => (a -> g) -> [a] -> [(g, [a])]
groupByEq f as = zip gs groups where
  groups = groupBy (eqUnder f) as
  gs = map (f . head) groups


postRaiseTaskR :: TaskId -> Handler RepHtml
postRaiseTaskR = reorderTaskR Up

postLowerTaskR :: TaskId -> Handler RepHtml
postLowerTaskR = reorderTaskR Down

reorderTaskR :: Direction -> TaskId -> Handler RepHtml
reorderTaskR direction = authedTask (\task -> do
  utcNow <- liftIO getCurrentTime
  tz <- liftIO getCurrentTimeZone
  let endOfToday = locally tz localEndOfDay utcNow

  runDB $ reorderTask direction endOfToday task
  redirectTemporary TasksR)


postPostponeTaskR :: TaskId -> Handler RepHtml
postPostponeTaskR = authedTask (\task -> do
  runDB $ postponeTask task
  redirectTemporary TasksR)


postActivateTaskR :: TaskId -> Handler RepHtml
postActivateTaskR = authedTask (\(taskId, _) -> do
  now <- liftIO getCurrentTime
  runDB $ activateTask now taskId
  redirectTemporary TasksR)
Something went wrong with that request. Please try again.