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