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