1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards, DataKinds #-}
    2 module Model.Container
    3   ( module Model.Container.Types
    4   , blankContainer
    5   , lookupContainer
    6   , lookupVolumeContainer
    7   , lookupVolumeContainers
    8   , lookupVolumeTopContainer
    9   , containerIsVolumeTop
   10   , addContainer
   11   , changeContainer
   12   , removeContainer
   13   , getContainerDate
   14   , formatContainerDate
   15   , containerRowJSON
   16   , containerJSON
   17   ) where
   18 
   19 import Control.Monad (guard)
   20 import qualified Data.ByteString
   21 import Data.Either (isRight)
   22 import Data.Monoid ((<>))
   23 import qualified Data.String
   24 import Data.Time.Format (formatTime, defaultTimeLocale)
   25 import Database.PostgreSQL.Typed.Types
   26 -- import Database.PostgreSQL.Typed.Query (pgSQL)
   27 
   28 import Ops
   29 import Has (view, peek)
   30 import Service.DB
   31 import qualified JSON
   32 import Model.SQL (selectQuery, isForeignKeyViolation)
   33 import Model.Time
   34 import Model.Permission
   35 import Model.Id.Types
   36 import Model.Party.Types
   37 import Model.Identity
   38 import Model.Audit
   39 import Model.Volume.Types
   40 import Model.Container.Types
   41 import Model.Container.SQL
   42 import Model.PermissionUtil (maskRestrictedString)
   43 
   44 blankContainer :: Volume -> Container
   45 blankContainer vol = Container
   46   { containerRow = ContainerRow
   47     { containerId = error "blankContainer"
   48     , containerTop = False
   49     , containerName = Nothing
   50     , containerDate = Nothing
   51     }
   52   , containerRelease = Nothing
   53   , containerVolume = vol
   54   }
   55 
   56 -- | Look up a Container by its Id, gated by the running Identity's permission
   57 -- to view the Volume containing the Container.
   58 lookupContainer :: (MonadDB c m, MonadHasIdentity c m) => Id Container -> m (Maybe Container)
   59 lookupContainer ci = do
   60   ident <- peek
   61   dbQuery1 $(selectQuery (selectContainer 'ident) "$WHERE container.id = ${ci}")
   62 
   63 lookupVolumeContainer :: MonadDB c m => Volume -> Id Container -> m (Maybe Container)
   64 lookupVolumeContainer vol ci =
   65   dbQuery1 $ fmap ($ vol) $(selectQuery selectVolumeContainer "$WHERE container.id = ${ci} AND container.volume = ${volumeId $ volumeRow vol}")
   66 
   67 lookupVolumeContainers :: MonadDB c m => Volume -> m [Container]
   68 lookupVolumeContainers vol =
   69   dbQuery $ fmap ($ vol) $(selectQuery selectVolumeContainer "$WHERE container.volume = ${volumeId $ volumeRow vol} ORDER BY container.id")
   70 
   71 lookupVolumeTopContainer :: MonadDB c m => Volume -> m Container
   72 lookupVolumeTopContainer vol =
   73   dbQuery1' $ fmap ($ vol) $(selectQuery selectVolumeContainer "$WHERE container.volume = ${volumeId $ volumeRow vol} ORDER BY container.id LIMIT 1")
   74 
   75 containerIsVolumeTop :: MonadDB c m => Container -> m Bool
   76 containerIsVolumeTop Container{ containerRow = ContainerRow{ containerTop = False } } = return False
   77 containerIsVolumeTop c = do
   78   let _tenv_a87pL = unknownPGTypeEnv
   79   not <$>
   80     dbExecute1 -- [pgSQL|SELECT FROM container WHERE volume = ${volumeId $ volumeRow $ containerVolume c} AND id < ${containerId $ containerRow c} LIMIT 1|]
   81       (mapQuery2
   82             ((\ _p_a87pM _p_a87pN ->
   83                     (Data.ByteString.concat
   84                        [Data.String.fromString "SELECT FROM container WHERE volume = ",
   85                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
   86                           _tenv_a87pL
   87                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
   88                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
   89                           _p_a87pM,
   90                         Data.String.fromString " AND id < ",
   91                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
   92                           _tenv_a87pL
   93                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
   94                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
   95                           _p_a87pN,
   96                         Data.String.fromString " LIMIT 1"]))
   97              (volumeId $ volumeRow $ containerVolume c)
   98              (containerId $ containerRow c))
   99             (\[] -> ()))
  100 
  101 addContainer :: MonadAudit c m => Container -> m Container
  102 addContainer bc = do
  103   ident <- getAuditIdentity
  104   let _tenv_a87ru = unknownPGTypeEnv
  105   row <- dbQuery1' -- .(insertContainer 'ident 'bc)
  106     (mapQuery2
  107       ((\ _p_a87rv _p_a87rw _p_a87rx _p_a87ry _p_a87rz _p_a87rA ->
  108                        (Data.ByteString.concat
  109                           [Data.String.fromString
  110                              "WITH audit_row AS (INSERT INTO container (volume,top,name,date) VALUES (",
  111                            Database.PostgreSQL.Typed.Types.pgEscapeParameter
  112                              _tenv_a87ru
  113                              (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  114                                 Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  115                              _p_a87rv,
  116                            Data.String.fromString ",",
  117                            Database.PostgreSQL.Typed.Types.pgEscapeParameter
  118                              _tenv_a87ru
  119                              (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  120                                 Database.PostgreSQL.Typed.Types.PGTypeName "boolean")
  121                              _p_a87rw,
  122                            Data.String.fromString ",",
  123                            Database.PostgreSQL.Typed.Types.pgEscapeParameter
  124                              _tenv_a87ru
  125                              (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  126                                 Database.PostgreSQL.Typed.Types.PGTypeName "text")
  127                              _p_a87rx,
  128                            Data.String.fromString ",",
  129                            Database.PostgreSQL.Typed.Types.pgEscapeParameter
  130                              _tenv_a87ru
  131                              (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  132                                 Database.PostgreSQL.Typed.Types.PGTypeName "date")
  133                              _p_a87ry,
  134                            Data.String.fromString
  135                              ") RETURNING *) INSERT INTO audit.container SELECT CURRENT_TIMESTAMP, ",
  136                            Database.PostgreSQL.Typed.Types.pgEscapeParameter
  137                              _tenv_a87ru
  138                              (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  139                                 Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  140                              _p_a87rz,
  141                            Data.String.fromString ", ",
  142                            Database.PostgreSQL.Typed.Types.pgEscapeParameter
  143                              _tenv_a87ru
  144                              (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  145                                 Database.PostgreSQL.Typed.Types.PGTypeName "inet")
  146                              _p_a87rA,
  147                            Data.String.fromString
  148                              ", 'add'::audit.action, * FROM audit_row RETURNING container.id"]))
  149          (volumeId $ volumeRow $ containerVolume bc)
  150          (containerTop $ containerRow bc)
  151          (containerName $ containerRow bc)
  152          (containerDate $ containerRow bc)
  153          (auditWho ident)
  154          (auditIp ident))
  155         (\[_cid_a87rB]
  156                   -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  157                         _tenv_a87ru
  158                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  159                            Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  160                         _cid_a87rB)))
  161   pure
  162       (Model.Container.SQL.setContainerId bc
  163       row)
  164 
  165 
  166 changeContainer :: MonadAudit c m => Container -> m ()
  167 changeContainer c = do
  168   ident <- getAuditIdentity
  169   let _tenv_a87BH = unknownPGTypeEnv
  170   dbExecute1' -- .(updateContainer 'ident 'c)
  171     (mapQuery2
  172       ((\ _p_a87BI _p_a87BJ _p_a87BK _p_a87BL _p_a87BM _p_a87BN _p_a87BO ->
  173                     (Data.ByteString.concat
  174                        [Data.String.fromString
  175                           "WITH audit_row AS (UPDATE container SET volume=",
  176                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  177                           _tenv_a87BH
  178                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  179                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  180                           _p_a87BI,
  181                         Data.String.fromString ",top=",
  182                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  183                           _tenv_a87BH
  184                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  185                              Database.PostgreSQL.Typed.Types.PGTypeName "boolean")
  186                           _p_a87BJ,
  187                         Data.String.fromString ",name=",
  188                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  189                           _tenv_a87BH
  190                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  191                              Database.PostgreSQL.Typed.Types.PGTypeName "text")
  192                           _p_a87BK,
  193                         Data.String.fromString ",date=",
  194                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  195                           _tenv_a87BH
  196                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  197                              Database.PostgreSQL.Typed.Types.PGTypeName "date")
  198                           _p_a87BL,
  199                         Data.String.fromString " WHERE id=",
  200                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  201                           _tenv_a87BH
  202                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  203                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  204                           _p_a87BM,
  205                         Data.String.fromString
  206                           " RETURNING *) INSERT INTO audit.container SELECT CURRENT_TIMESTAMP, ",
  207                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  208                           _tenv_a87BH
  209                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  210                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  211                           _p_a87BN,
  212                         Data.String.fromString ", ",
  213                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  214                           _tenv_a87BH
  215                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  216                              Database.PostgreSQL.Typed.Types.PGTypeName "inet")
  217                           _p_a87BO,
  218                         Data.String.fromString
  219                           ", 'change'::audit.action, * FROM audit_row"]))
  220       (volumeId $ volumeRow $ containerVolume c)
  221       (containerTop $ containerRow c)
  222       (containerName $ containerRow c)
  223       (containerDate $ containerRow c)
  224       (containerId $ containerRow c)
  225       (auditWho ident)
  226       (auditIp ident))
  227     (\[] -> ()))
  228 
  229 removeContainer :: MonadAudit c m => Container -> m Bool
  230 removeContainer c = do
  231   ident <- getAuditIdentity
  232   let (_tenv_a87HO, _tenv_a87LM) = (unknownPGTypeEnv, unknownPGTypeEnv)
  233   top <- dbQuery1' -- [pgSQL|SELECT id FROM container WHERE volume = ${volumeId $ volumeRow $ containerVolume c} ORDER BY id LIMIT 1|]
  234     (mapQuery2
  235        ((\ _p_a87HP ->
  236                     Data.ByteString.concat
  237                        [Data.String.fromString "SELECT id FROM container WHERE volume = ",
  238                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  239                           _tenv_a87HO
  240                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  241                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  242                           _p_a87HP,
  243                         Data.String.fromString " ORDER BY id LIMIT 1"])
  244           (volumeId $ volumeRow $ containerVolume c))
  245        (\[_cid_a87HR]
  246                -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  247                      _tenv_a87HO
  248                      (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  249                         Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  250                      _cid_a87HR)))
  251   if top == containerId (containerRow c)
  252     then return False
  253     else
  254       isRight
  255         <$>
  256           dbTryJust
  257             (guard . isForeignKeyViolation)
  258             (dbExecute1 -- .(deleteContainer 'ident 'c))
  259               (mapQuery2
  260                 ((\ _p_a87LN _p_a87LO _p_a87LP ->
  261                                 (Data.ByteString.concat
  262                                    [Data.String.fromString
  263                                       "WITH audit_row AS (DELETE FROM container WHERE id=",
  264                                     Database.PostgreSQL.Typed.Types.pgEscapeParameter
  265                                       _tenv_a87LM
  266                                       (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  267                                          Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  268                                       _p_a87LN,
  269                                     Data.String.fromString
  270                                       " RETURNING *) INSERT INTO audit.container SELECT CURRENT_TIMESTAMP, ",
  271                                     Database.PostgreSQL.Typed.Types.pgEscapeParameter
  272                                       _tenv_a87LM
  273                                       (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  274                                          Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  275                                       _p_a87LO,
  276                                     Data.String.fromString ", ",
  277                                     Database.PostgreSQL.Typed.Types.pgEscapeParameter
  278                                       _tenv_a87LM
  279                                       (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  280                                          Database.PostgreSQL.Typed.Types.PGTypeName "inet")
  281                                       _p_a87LP,
  282                                     Data.String.fromString
  283                                       ", 'remove'::audit.action, * FROM audit_row"]))
  284                  (containerId $ containerRow c) (auditWho ident) (auditIp ident))
  285                 (\ [] -> ())))
  286 
  287 getContainerDate :: Container -> Maybe MaskedDate
  288 getContainerDate c =
  289   maskDateIf (not (canReadData2 getContainerRelease getContainerVolumeRole c))
  290     <$> containerDate (containerRow c)
  291 
  292 formatContainerDate :: Container -> Maybe String
  293 formatContainerDate c = formatTime defaultTimeLocale "%Y-%m-%d" <$> getContainerDate c
  294 
  295 containerRowJSON :: JSON.ToObject o => Bool -> ContainerRow -> JSON.Record (Id Container) o
  296 containerRowJSON publicRestricted ContainerRow{..} = JSON.Record containerId $
  297      "top" `JSON.kvObjectOrEmpty` (True `useWhen` containerTop)
  298   <> "name" `JSON.kvObjectOrEmpty` if publicRestricted then fmap maskRestrictedString containerName else containerName
  299 
  300 containerJSON :: JSON.ToObject o => Bool -> Container -> JSON.Record (Id Container) o
  301 containerJSON publicRestricted c@Container{..} = containerRowJSON publicRestricted containerRow `JSON.foldObjectIntoRec`
  302  (   "date" `JSON.kvObjectOrEmpty` formatContainerDate c
  303   <> "release" `JSON.kvObjectOrEmpty` containerRelease)