1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.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 Data.Maybe (isNothing, fromMaybe) 16 import qualified Data.Text as T 17 import Network.HTTP.Types (noContent204, conflict409) 18 19 -- import Databrary.Ops 20 -- import Databrary.Has 21 import qualified Databrary.JSON as JSON 22 import Databrary.Action.Route 23 import Databrary.Action.Response 24 import Databrary.Action 25 import Databrary.Model.Id 26 import Databrary.Model.Volume 27 import Databrary.Model.Permission 28 import Databrary.Model.Record 29 import Databrary.Model.Category 30 import Databrary.Model.RecordSlot 31 import Databrary.Model.Metric 32 import Databrary.Model.Measure 33 import Databrary.Model.Segment 34 import Databrary.Model.Slot 35 import Databrary.HTTP.Form.Deform 36 import Databrary.HTTP.Path.Parser 37 import Databrary.Controller.Paths 38 import Databrary.Controller.Form 39 import Databrary.Controller.Volume 40 import Databrary.Controller.Slot 41 import Databrary.Controller.Permission 42 -- import Databrary.View.Record 43 import Databrary.View.Form (FormHtml) 44 45 getRecord :: Permission -> Id Record -> Handler Record 46 getRecord p i = 47 checkPermission p =<< maybeAction =<< lookupRecord i 48 49 viewRecord :: ActionRoute (Id Record) 50 viewRecord = action GET (pathJSON >/> pathId) $ \i -> withAuth $ do 51 rec <- getRecord PermissionPUBLIC i 52 let v = recordVolume rec 53 _ <- maybeAction (if volumeIsPublicRestricted v then Nothing else Just ()) -- block if restricted 54 return $ okResponse [] $ JSON.recordEncoding $ recordJSON False rec -- json should consult volume 55 -- HTML -> okResponse [] $ T.pack $ show $ recordId $ recordRow rec -- TODO 56 57 createRecord :: ActionRoute (Id Volume) 58 createRecord = action POST (pathJSON >/> pathId </< "record") $ \vi -> withAuth $ do 59 vol <- getVolume PermissionEDIT vi 60 br <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ do 61 csrfForm 62 cat <- "category" .:> (deformMaybe' "No such category" . getCategory =<< deform) 63 return $ blankRecord cat vol 64 rec <- addRecord br 65 return $ okResponse [] $ JSON.recordEncoding $ recordJSON False rec -- recordJSON not restricted because EDIT 66 -- HTML -> peeks $ otherRouteResponse [] viewRecord (api, recordId $ recordRow rec) 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 mDatum <- 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 -- HTML -> peeks $ otherRouteResponse [] viewRecord (api, recordId $ recordRow rec') 90 91 deleteRecord :: ActionRoute (Id Record) 92 deleteRecord = action DELETE (pathJSON >/> pathId) $ \ri -> withAuth $ do 93 guardVerfHeader 94 rec <- getRecord PermissionEDIT ri 95 r <- removeRecord rec 96 unless r $ result $ 97 response conflict409 [] $ JSON.recordEncoding $ recordJSON False rec -- json not restricted because edit 98 -- HTML -> response conflict409 [] ("This record is still used" :: T.Text) 99 return $ emptyResponse noContent204 [] 100 -- HTML -> peeks $ otherRouteResponse [] viewVolume (api, view rec) 101 102 postRecordSlot :: ActionRoute (Id Slot, Id Record) 103 postRecordSlot = action POST (pathJSON >/> pathSlotId </> pathId) $ \(si, ri) -> withAuth $ do 104 slot <- getSlot PermissionEDIT Nothing si 105 rec <- getRecord PermissionEDIT ri 106 src <- runForm Nothing $ do 107 csrfForm 108 "src" .:> deformNonEmpty deform 109 r <- moveRecordSlot (RecordSlot rec slot{ slotSegment = fromMaybe emptySegment src }) (slotSegment slot) 110 -- HTML | r -> peeks $ otherRouteResponse [] (viewSlot False) (api, (Just (view slot), slotId slot)) 111 -- | otherwise -> peeks $ otherRouteResponse [] viewRecord (api, recordId $ recordRow rec) 112 if r 113 then return $ okResponse [] $ JSON.recordEncoding $ recordSlotJSON False (RecordSlot rec slot) 114 else return $ okResponse [] $ JSON.recordEncoding $ recordJSON False rec -- recordJSON not restricted because EDIT 115 116 deleteRecordSlot :: ActionRoute (Id Slot, Id Record) 117 deleteRecordSlot = action DELETE (pathJSON >/> pathSlotId </> pathId) $ \(si, ri) -> withAuth $ do 118 guardVerfHeader 119 slot <- getSlot PermissionEDIT Nothing si 120 rec <- getRecord PermissionEDIT ri 121 r <- moveRecordSlot (RecordSlot rec slot) emptySegment 122 -- HTML | r -> peeks $ otherRouteResponse [] viewRecord (api, recordId $ recordRow rec) 123 if r 124 then return $ okResponse [] $ JSON.recordEncoding $ recordJSON False rec -- json not restricted because edit 125 else return $ emptyResponse noContent204 [] 126 127 deleteRecordAllSlot :: ActionRoute (Id Record) 128 deleteRecordAllSlot = action DELETE (pathJSON >/> "slot" >/> "all" >/> pathId) $ \ri -> withAuth $ do 129 guardVerfHeader 130 rec <- getRecord PermissionEDIT ri 131 _ <- removeRecordAllSlot rec 132 -- HTML -> peeks $ otherRouteResponse [] viewRecord (api, recordId $ recordRow rec) 133 return $ okResponse [] $ JSON.recordEncoding $ recordJSON False rec -- json not restricted because edit