1 {-# LANGUAGE OverloadedStrings #-} 2 module Controller.Record 3 ( getRecord 4 , viewRecord 5 , createRecord 6 , postRecordMeasure 7 , deleteRecord 8 , postRecordSlot 9 , deleteRecordSlot 10 , deleteRecordAllSlot 11 ) where 12 13 import Control.Monad (when, unless) 14 import Control.Monad.Trans.Class (lift) 15 import qualified Data.ByteString as BS 16 import Data.Maybe (isNothing, fromMaybe) 17 import qualified Data.Text as T 18 import Network.HTTP.Types (noContent204, conflict409) 19 20 import qualified JSON 21 import Action.Route 22 import Action.Response 23 import Action 24 import Model.Id 25 import Model.Volume 26 import Model.Permission hiding (checkPermission) 27 import Model.Record 28 import Model.Category 29 import Model.RecordSlot 30 import Model.Metric 31 import Model.Measure 32 import Model.Segment 33 import Model.Slot 34 import HTTP.Form.Deform 35 import HTTP.Path.Parser 36 import Controller.Paths 37 import Controller.Form 38 import Controller.Volume 39 import Controller.Slot 40 import Controller.Permission 41 import View.Form (FormHtml) 42 43 getRecord :: Permission -> Id Record -> Handler Record 44 getRecord p i = 45 checkPermissionOld p =<< maybeAction =<< lookupRecord i 46 47 viewRecord :: ActionRoute (Id Record) 48 viewRecord = action GET (pathJSON >/> pathId) $ \i -> withAuth $ do 49 rec <- getRecord PermissionPUBLIC i 50 let v = recordVolume rec 51 _ <- maybeAction (if volumeIsPublicRestricted v then Nothing else Just ()) -- block if restricted 52 return $ okResponse [] $ JSON.recordEncoding $ recordJSON False rec -- json should consult volume 53 54 data CreateRecordRequest = CreateRecordRequest Category 55 56 createRecord :: ActionRoute (Id Volume) 57 createRecord = action POST (pathJSON >/> pathId </< "record") $ \vi -> withAuth $ do 58 vol <- getVolume PermissionEDIT vi 59 br <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ do 60 csrfForm 61 CreateRecordRequest cat <- CreateRecordRequest <$> ("category" .:> (deformMaybe' "No such category" . getCategory =<< deform)) 62 return $ blankRecord cat vol 63 rec <- addRecord br 64 return $ okResponse [] $ JSON.recordEncoding $ recordJSON False rec -- recordJSON not restricted because EDIT 65 66 data ManageRecordMeasureRequest = ManageRecordMeasureRequest (Maybe BS.ByteString) 67 68 postRecordMeasure :: ActionRoute (Id Record, Id Metric) 69 postRecordMeasure = action POST (pathJSON >/> pathId </> pathId) $ \(ri, mi) -> withAuth $ do 70 record <- getRecord PermissionEDIT ri 71 met <- maybeAction $ getMetric mi 72 let mkMeasure datum = Measure record met datum 73 rec' <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ do 74 csrfForm 75 ManageRecordMeasureRequest mDatum <- ManageRecordMeasureRequest <$> deformSync' ("datum" .:> deformNonEmpty deform) 76 maybe 77 (lift $ removeRecordMeasure $ mkMeasure "") -- delete measure data 78 (\d -> do -- add or update measure data 79 mRecord <- lift $ changeRecordMeasure $ mkMeasure d 80 when (isNothing mRecord) $ 81 deformError $ 82 T.pack $ 83 "Invalid " 84 ++ show (metricType met) 85 ++ (if metricType met == MeasureTypeDate then " (please use YYYY-MM-DD)" else "") 86 return $ fromMaybe record mRecord) 87 mDatum 88 return $ okResponse [] $ JSON.recordEncoding $ recordJSON False rec' -- recordJSON not restricted because EDIT 89 90 deleteRecord :: ActionRoute (Id Record) 91 deleteRecord = action DELETE (pathJSON >/> pathId) $ \ri -> withAuth $ do 92 guardVerfHeader 93 rec <- getRecord PermissionEDIT ri 94 r <- removeRecord rec 95 unless r $ result $ 96 response conflict409 [] $ JSON.recordEncoding $ recordJSON False rec -- json not restricted because edit 97 return $ emptyResponse noContent204 [] 98 99 data UpdateRecordSlotRequest = UpdateRecordSlotRequest (Maybe Segment) 100 101 postRecordSlot :: ActionRoute (Id Slot, Id Record) 102 postRecordSlot = action POST (pathJSON >/> pathSlotId </> pathId) $ \(si, ri) -> withAuth $ do 103 slot <- getSlot PermissionEDIT si 104 rec <- getRecord PermissionEDIT ri 105 UpdateRecordSlotRequest src <- runForm Nothing $ do 106 csrfForm 107 UpdateRecordSlotRequest <$> ("src" .:> deformNonEmpty deform) 108 r <- moveRecordSlot (RecordSlot rec slot{ slotSegment = fromMaybe emptySegment src }) (slotSegment slot) 109 if r 110 then return $ okResponse [] $ JSON.recordEncoding $ recordSlotJSON False (RecordSlot rec slot) 111 else return $ okResponse [] $ JSON.recordEncoding $ recordJSON False rec -- recordJSON not restricted because EDIT 112 113 deleteRecordSlot :: ActionRoute (Id Slot, Id Record) 114 deleteRecordSlot = action DELETE (pathJSON >/> pathSlotId </> pathId) $ \(si, ri) -> withAuth $ do 115 guardVerfHeader 116 slot <- getSlot PermissionEDIT si 117 rec <- getRecord PermissionEDIT ri 118 r <- moveRecordSlot (RecordSlot rec slot) emptySegment 119 if r 120 then return $ okResponse [] $ JSON.recordEncoding $ recordJSON False rec -- json not restricted because edit 121 else return $ emptyResponse noContent204 [] 122 123 deleteRecordAllSlot :: ActionRoute (Id Record) 124 deleteRecordAllSlot = action DELETE (pathJSON >/> "slot" >/> "all" >/> pathId) $ \ri -> withAuth $ do 125 guardVerfHeader 126 rec <- getRecord PermissionEDIT ri 127 _ <- removeRecordAllSlot rec 128 return $ okResponse [] $ JSON.recordEncoding $ recordJSON False rec -- json not restricted because edit