1 {-# LANGUAGE OverloadedStrings, RecordWildCards #-}
    2 module Databrary.Controller.Container
    3   ( getContainer
    4   , viewContainer
    5   , viewContainerEdit
    6   , createContainer
    7   , postContainer
    8   , deleteContainer
    9   , containerDownloadName
   10   ) where
   11 
   12 import Control.Arrow (second)
   13 import Control.Monad (when, unless, mfilter)
   14 import qualified Data.Invertible as I
   15 import Data.Maybe (fromMaybe, maybeToList, isJust)
   16 import qualified Data.Text as T
   17 import Network.HTTP.Types (noContent204, movedPermanently301, conflict409)
   18 import qualified Web.Route.Invertible as R
   19 
   20 import Databrary.Has
   21 import qualified Databrary.JSON as JSON
   22 import Databrary.Model.Id
   23 import Databrary.Model.Permission
   24 import Databrary.Model.Volume
   25 import Databrary.Model.Container
   26 import Databrary.Model.Segment
   27 import Databrary.Model.Slot
   28 import Databrary.Model.Release
   29 import Databrary.Model.Notification.Types
   30 import Databrary.Action.Response
   31 import Databrary.Action
   32 import Databrary.HTTP.Form.Deform
   33 import Databrary.HTTP.Path.Parser
   34 import Databrary.Controller.Paths
   35 import Databrary.Controller.Permission
   36 import Databrary.Controller.Form
   37 import Databrary.Controller.Angular
   38 import Databrary.Controller.Volume
   39 import Databrary.Controller.Notification
   40 import {-# SOURCE #-} Databrary.Controller.Slot
   41 -- import Databrary.View.Container
   42 import Databrary.View.Form (FormHtml)
   43 
   44 getContainer :: Permission -> Maybe (Id Volume) -> Id Slot -> Bool -> Handler Container
   45 getContainer p mv (Id (SlotId i s)) top
   46   | segmentFull s = do
   47     c <- checkPermission p =<< maybeAction . maybe id (\v -> mfilter $ (v ==) . view) mv =<< lookupContainer i
   48     unless top $ do
   49       t <- lookupVolumeTopContainer (containerVolume c)
   50       when (containerId (containerRow c) == containerId (containerRow t)) $ result =<< peeks notFoundResponse
   51     return c
   52   | otherwise = result =<< peeks notFoundResponse
   53 
   54 containerDownloadName :: Container -> [T.Text]
   55 containerDownloadName Container{ containerRow = ContainerRow{..} } =
   56   (if containerTop then ("materials" :) else id) $
   57     T.pack (show containerId) : maybeToList containerName
   58 
   59 viewContainer :: ActionRoute (API, (Maybe (Id Volume), Id Container))
   60 viewContainer = second (second $ slotContainerId . unId I.:<->: containerSlotId) `R.mapActionRoute` (viewSlot False)
   61 
   62 containerForm :: Container -> DeformHandler () Container
   63 containerForm c = do
   64   csrfForm
   65   name <- "name" .:> deformOptional (deformNonEmpty deform)
   66   top <- "top" .:> deformOptional deform
   67   date <- "date" .:> deformOptional (deformNonEmpty deform)
   68   release <- "release" .:> deformOptional (deformNonEmpty deform)
   69   return c
   70     { containerRow = (containerRow c)
   71       { containerName = fromMaybe (containerName $ containerRow c) name
   72       , containerTop = fromMaybe (containerTop $ containerRow c) top
   73       , containerDate = fromMaybe (containerDate $ containerRow c) date
   74       }
   75     , containerRelease = fromMaybe (containerRelease c) release
   76     }
   77 
   78 viewContainerEdit :: ActionRoute (Maybe (Id Volume), Id Slot)
   79 viewContainerEdit = action GET (pathHTML >/> pathMaybe pathId </> pathSlotId </< "edit") $ \(vi, ci) -> withAuth $ do
   80   when (isJust vi) $ angular
   81   c <- getContainer PermissionEDIT vi ci False
   82   unless (isJust vi) $
   83     result =<< peeks (redirectRouteResponse movedPermanently301 [] viewContainerEdit (Just (view c), containerSlotId (view c)))
   84   return $ okResponse [] $ ("" :: String) -- should never get here
   85   -- peeks $ blankForm . htmlContainerEdit (Right c)
   86 
   87 createContainer :: ActionRoute (Id Volume)
   88 createContainer = action POST (pathJSON >/> pathId </< "slot") $ \vi -> withAuth $ do
   89   vol <- getVolume PermissionEDIT vi
   90   bc <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ containerForm (blankContainer vol)
   91   c <- addContainer bc
   92   -- TODO: NoticeReleaseSlot?
   93   -- case api of
   94   return $ okResponse [] $ JSON.recordEncoding $ containerJSON False c -- False because level EDIT
   95   -- HTML -> peeks $ otherRouteResponse [] viewContainer (api, (Just vi, containerId $ containerRow c))
   96 
   97 postContainer :: ActionRoute (Id Slot)
   98 postContainer = action POST (pathJSON >/> pathSlotId) $ \(ci) -> withAuth $ do
   99   c <- getContainer PermissionEDIT Nothing ci False
  100   c' <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ containerForm c
  101   changeContainer c'
  102   when (containerRelease c' /= containerRelease c) $ do
  103     r <- changeRelease (containerSlot c') (containerRelease c')
  104     unless r $
  105       result $ emptyResponse conflict409 []
  106     when (containerRelease c' == Just ReleasePUBLIC && not (containerTop $ containerRow c')) $
  107       createVolumeNotification (containerVolume c) $ \n -> (n NoticeReleaseSlot)
  108         { notificationContainerId = Just $ containerId $ containerRow c'
  109         , notificationRelease = containerRelease c'
  110         }
  111   return $ okResponse [] $ JSON.recordEncoding $ containerJSON False c' -- False because level EDIT
  112   --HTML -> peeks $ otherRouteResponse [] (viewSlot False) (api, (Just (view c'), ci))
  113 
  114 deleteContainer :: ActionRoute (Id Slot)
  115 deleteContainer = action DELETE (pathJSON >/> pathSlotId) $ \ci -> withAuth $ do
  116   guardVerfHeader
  117   c <- getContainer PermissionEDIT Nothing ci False
  118   r <- removeContainer c
  119   unless r $ result $ 
  120     response conflict409 [] $ JSON.recordEncoding $ containerJSON False c -- False because level EDIT
  121     -- HTML -> response conflict409 [] ("This container is not empty." :: T.Text)
  122   return $ emptyResponse noContent204 []
  123   -- HTML -> peeks $ otherRouteResponse [] viewVolume (api, view c)