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)