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)