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