1 {-# LANGUAGE OverloadedStrings, RecordWildCards #-}
    2 module 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 Data.Time (Day)
   18 import Network.HTTP.Types (noContent204, movedPermanently301, conflict409)
   19 import qualified Web.Route.Invertible as R
   20 
   21 import Has
   22 import qualified JSON
   23 import Model.Id
   24 import Model.Permission hiding (checkPermission)
   25 import Model.Volume
   26 import Model.Container
   27 import Model.Segment
   28 import Model.Slot
   29 import Model.Release
   30 import Model.Notification.Types
   31 import Action.Response
   32 import Action
   33 import HTTP.Form.Deform
   34 import HTTP.Path.Parser
   35 import Controller.Paths
   36 import Controller.Permission
   37 import Controller.Form
   38 import Controller.Angular
   39 import Controller.Volume
   40 import Controller.Notification
   41 import {-# SOURCE #-} Controller.Slot
   42 import 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 <- checkPermissionOld p =<< maybeAction . maybe id (\v -> mfilter $ (v ==) . volumeId . volumeRow . containerVolume) 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 data CreateOrUpdateContainerRequest =
   63     CreateOrUpdateContainerRequest (Maybe (Maybe T.Text)) (Maybe Bool) (Maybe (Maybe Day)) (Maybe (Maybe Release))
   64 
   65 containerForm :: Container -> DeformHandler () Container
   66 containerForm c = do
   67   csrfForm
   68   name <- "name" .:> deformOptional (deformNonEmpty deform)
   69   top <- "top" .:> deformOptional deform
   70   date <- "date" .:> deformOptional (deformNonEmpty deform)
   71   release <- "release" .:> deformOptional (deformNonEmpty deform)
   72   let _ = CreateOrUpdateContainerRequest name top date release
   73   return c
   74     { containerRow = (containerRow c)
   75       { containerName = fromMaybe (containerName $ containerRow c) name
   76       , containerTop = fromMaybe (containerTop $ containerRow c) top
   77       , containerDate = fromMaybe (containerDate $ containerRow c) date
   78       }
   79     , containerRelease = fromMaybe (containerRelease c) release
   80     }
   81 
   82 viewContainerEdit :: ActionRoute (Maybe (Id Volume), Id Slot)
   83 viewContainerEdit = action GET (pathHTML >/> pathMaybe pathId </> pathSlotId </< "edit") $ \(vi, ci) -> withAuth $ do
   84   when (isJust vi) angular
   85   c <- getContainer PermissionEDIT vi ci False
   86   unless (isJust vi) $
   87     result =<< peeks (redirectRouteResponse movedPermanently301 [] viewContainerEdit (Just ((volumeId . volumeRow . containerVolume) c), containerSlotId (view c)))
   88   return $ okResponse [] ("" :: String) -- should never get here
   89   -- peeks $ blankForm . htmlContainerEdit (Right c)
   90 
   91 createContainer :: ActionRoute (Id Volume)
   92 createContainer = action POST (pathJSON >/> pathId </< "slot") $ \vi -> withAuth $ do
   93   vol <- getVolume PermissionEDIT vi
   94   bc <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ containerForm (blankContainer vol)
   95   c <- addContainer bc
   96   -- TODO: NoticeReleaseSlot?
   97   -- case api of
   98   return $ okResponse [] $ JSON.recordEncoding $ containerJSON False c -- False because level EDIT
   99   -- HTML -> peeks $ otherRouteResponse [] viewContainer (api, (Just vi, containerId $ containerRow c))
  100 
  101 postContainer :: ActionRoute (Id Slot)
  102 postContainer = action POST (pathJSON >/> pathSlotId) $ \ci -> withAuth $ do
  103   c <- getContainer PermissionEDIT Nothing ci False
  104   c' <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ containerForm c
  105   changeContainer c'
  106   when (containerRelease c' /= containerRelease c) $ do
  107     r <- changeRelease (containerSlot c') (containerRelease c')
  108     unless r $
  109       result $ emptyResponse conflict409 []
  110     when (containerRelease c' == Just ReleasePUBLIC && not (containerTop $ containerRow c')) $
  111       createVolumeNotification (containerVolume c) $ \n -> (n NoticeReleaseSlot)
  112         { notificationContainerId = Just $ containerId $ containerRow c'
  113         , notificationRelease = containerRelease c'
  114         }
  115   return $ okResponse [] $ JSON.recordEncoding $ containerJSON False c' -- False because level EDIT
  116   --HTML -> peeks $ otherRouteResponse [] (viewSlot False) (api, (Just (view c'), ci))
  117 
  118 deleteContainer :: ActionRoute (Id Slot)
  119 deleteContainer = action DELETE (pathJSON >/> pathSlotId) $ \ci -> withAuth $ do
  120   guardVerfHeader
  121   c <- getContainer PermissionEDIT Nothing ci False
  122   r <- removeContainer c
  123   unless r $ result $
  124     response conflict409 [] $ JSON.recordEncoding $ containerJSON False c -- False because level EDIT
  125     -- HTML -> response conflict409 [] ("This container is not empty." :: T.Text)
  126   return $ emptyResponse noContent204 []
  127   -- HTML -> peeks $ otherRouteResponse [] viewVolume (api, view c)