1 {-# LANGUAGE OverloadedStrings #-}
    2 module Controller.Periodic
    3   ( periodicHandler
    4     -- viewPeriodic
    5   , postPeriodic
    6   ) where
    7 
    8 import qualified Data.ByteString as BS
    9 import Control.Exception (throwTo)
   10 import Control.Monad.IO.Class (liftIO)
   11 import Network.HTTP.Types.Method (methodGet, methodPost)
   12 import qualified Network.HTTP.Types.Method as HTM
   13 
   14 import Has
   15 import Model.Periodic
   16 import Service.Types
   17 import Action
   18 import HTTP.Form.Deform
   19 import HTTP.Path.Parser
   20 import Controller.Permission
   21 import Controller.Form
   22 import View.Periodic
   23 
   24 periodicHandler :: HTM.Method -> [(BS.ByteString, BS.ByteString)] -> Action
   25 periodicHandler method _
   26     | method == methodGet = viewPeriodicHandler
   27     | method == methodPost = postPeriodicHandler
   28     | otherwise = error "unhandled api/method combo" -- TODO: better error
   29 
   30 {-
   31 viewPeriodic :: ActionRoute ()
   32 viewPeriodic = action GET ("admin" >/> "periodic") $ \() -> withAuth $ do
   33   checkMemberADMIN
   34   peeks $ blankForm . htmlPeriodic
   35 -}
   36 viewPeriodicHandler :: Action
   37 viewPeriodicHandler = withAuth $ do
   38   checkMemberADMIN
   39   peeks $ blankForm . htmlPeriodic
   40 
   41 postPeriodic :: ActionRoute ()
   42 postPeriodic = action POST ("admin" >/> "periodic") $ \() -> postPeriodicHandler
   43 
   44 data RunPeriodicRequest = RunPeriodicRequest Bool
   45 
   46 postPeriodicHandler :: Action
   47 postPeriodicHandler = withAuth $ do
   48   checkMemberADMIN
   49   t <- peeks servicePeriodic
   50   RunPeriodicRequest w <- runForm (Just htmlPeriodic) (RunPeriodicRequest <$> ("weekly" .:> deform))
   51   liftIO $ mapM_ (`throwTo` if w then PeriodWeekly else PeriodDaily) t
   52   return $ okResponse [] (maybe "no" (const "ok") t :: String)
   53