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