1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, DataKinds #-}
    2 module Databrary.Model.Token
    3   ( module Databrary.Model.Token.Types
    4   , loginTokenId
    5   , lookupLoginToken
    6   , createLoginToken
    7   , removeLoginToken
    8   , lookupSession
    9   , createSession
   10   , removeSession
   11   , lookupUpload
   12   , createUpload
   13   , removeUpload
   14   , cleanTokens
   15   ) where
   16 
   17 import Control.Monad (when, void, (<=<))
   18 import Control.Monad.IO.Class (MonadIO, liftIO)
   19 import Data.ByteArray (Bytes)
   20 import Data.ByteArray.Encoding (convertToBase, Base(Base64URLUnpadded))
   21 import qualified Data.ByteString as BS
   22 import Data.Int (Int64)
   23 import qualified Data.String
   24 import Database.PostgreSQL.Typed.Types
   25 -- import Database.PostgreSQL.Typed (pgSQL)
   26 -- import Database.PostgreSQL.Typed.Query (simpleQueryFlags)
   27 
   28 import Databrary.Ops
   29 import Databrary.Has
   30 import Databrary.Files (removeFile)
   31 import Databrary.Service.Types
   32 import Databrary.Service.Entropy
   33 import Databrary.Service.Crypto
   34 import Databrary.Service.DB
   35 import Databrary.Store.Types
   36 import Databrary.Store.Upload
   37 -- import Databrary.Model.SQL (selectQuery)
   38 -- import Databrary.Model.SQL.Select (makeQuery, selectOutput)
   39 import Databrary.Model.Offset
   40 import Databrary.Model.Id.Types
   41 import Databrary.Model.Identity.Types
   42 import Databrary.Model.Volume.Types
   43 import Databrary.Model.Party
   44 import Databrary.Model.Party.SQL
   45 import Databrary.Model.Permission.Types
   46 import Databrary.Model.Token.Types
   47 
   48 loginTokenId :: (MonadHas Entropy c m, MonadHas Secret c m, MonadIO m) => LoginToken -> m (Id LoginToken)
   49 loginTokenId tok = Id <$> sign (unId (view tok :: Id Token))
   50 
   51 -- | Attempt to find the matching one time login token for newly registered accounts,
   52 -- so that the user can view the password entry form as well as perform the password update.
   53 -- Retrieve the site auth with access deduced from inherited authorizations.
   54 -- Wrap the site auth in an AccountToken with the corresponding public token value and expiration.
   55 -- Wrap the AccountToken in a LoginToken with a boolean indicating ???? . Seems to be always true.
   56 lookupLoginToken :: (MonadDB c m, MonadHas Secret c m) => Id LoginToken -> m (Maybe LoginToken)
   57 lookupLoginToken =
   58   flatMapM (\t -> getToken t) -- dbQuery1 $(selectQuery selectLoginToken "$!WHERE login_token.token = ${t} AND expires > CURRENT_TIMESTAMP"))
   59     <=< unSign . unId
   60 
   61 getToken :: (MonadDB c m) => BS.ByteString -> m (Maybe LoginToken)
   62 getToken t = do
   63   let _tenv_aar3U = unknownPGTypeEnv
   64   mRow <- mapRunPrepQuery1
   65       ((\ _p_aar3V ->
   66                        (Data.String.fromString
   67                           "SELECT login_token.token,login_token.expires,party.id,party.name,party.prename,party.orcid,party.affiliation,party.url,account.email,account.password,authorize_view.site,authorize_view.member,login_token.password FROM login_token JOIN party JOIN account USING (id) LEFT JOIN authorize_view ON account.id = authorize_view.child AND authorize_view.parent = 0 ON login_token.account = account.id WHERE login_token.token = $1 AND expires > CURRENT_TIMESTAMP",
   68                        [pgEncodeParameter
   69                           _tenv_aar3U (PGTypeProxy :: PGTypeName "bpchar") _p_aar3V],
   70                        [pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "bpchar"),
   71                         pgBinaryColumn
   72                           _tenv_aar3U (PGTypeProxy :: PGTypeName "timestamp with time zone"),
   73                         pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "integer"),
   74                         pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "text"),
   75                         pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "text"),
   76                         pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "bpchar"),
   77                         pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "text"),
   78                         pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "text"),
   79                         pgBinaryColumn
   80                           _tenv_aar3U (PGTypeProxy :: PGTypeName "character varying"),
   81                         pgBinaryColumn
   82                           _tenv_aar3U (PGTypeProxy :: PGTypeName "character varying"),
   83                         pgBinaryColumn
   84                           _tenv_aar3U (PGTypeProxy :: PGTypeName "permission"),
   85                         pgBinaryColumn
   86                           _tenv_aar3U (PGTypeProxy :: PGTypeName "permission"),
   87                         pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "boolean")]))
   88          t)
   89                (\
   90                   [_ctoken_aar3W,
   91                    _cexpires_aar3X,
   92                    _cid_aar3Y,
   93                    _cname_aar3Z,
   94                    _cprename_aar40,
   95                    _corcid_aar41,
   96                    _caffiliation_aar42,
   97                    _curl_aar43,
   98                    _cemail_aar44,
   99                    _cpassword_aar45,
  100                    _csite_aar46,
  101                    _cmember_aar47,
  102                    _cpassword_aar48]
  103                   -> (pgDecodeColumnNotNull
  104                         _tenv_aar3U (PGTypeProxy :: PGTypeName "bpchar") _ctoken_aar3W, 
  105                       pgDecodeColumnNotNull
  106                         _tenv_aar3U
  107                         (PGTypeProxy :: PGTypeName "timestamp with time zone")
  108                         _cexpires_aar3X, 
  109                       pgDecodeColumnNotNull
  110                         _tenv_aar3U (PGTypeProxy :: PGTypeName "integer") _cid_aar3Y, 
  111                       pgDecodeColumnNotNull
  112                         _tenv_aar3U (PGTypeProxy :: PGTypeName "text") _cname_aar3Z, 
  113                       pgDecodeColumnNotNull
  114                         _tenv_aar3U (PGTypeProxy :: PGTypeName "text") _cprename_aar40, 
  115                       pgDecodeColumnNotNull
  116                         _tenv_aar3U (PGTypeProxy :: PGTypeName "bpchar") _corcid_aar41, 
  117                       pgDecodeColumnNotNull
  118                         _tenv_aar3U
  119                         (PGTypeProxy :: PGTypeName "text")
  120                         _caffiliation_aar42, 
  121                       pgDecodeColumnNotNull
  122                         _tenv_aar3U (PGTypeProxy :: PGTypeName "text") _curl_aar43, 
  123                       pgDecodeColumnNotNull
  124                         _tenv_aar3U
  125                         (PGTypeProxy :: PGTypeName "character varying")
  126                         _cemail_aar44, 
  127                       pgDecodeColumnNotNull
  128                         _tenv_aar3U
  129                         (PGTypeProxy :: PGTypeName "character varying")
  130                         _cpassword_aar45, 
  131                       pgDecodeColumnNotNull
  132                         _tenv_aar3U (PGTypeProxy :: PGTypeName "permission") _csite_aar46, 
  133                       pgDecodeColumnNotNull
  134                         _tenv_aar3U
  135                         (PGTypeProxy :: PGTypeName "permission")
  136                         _cmember_aar47, 
  137                       pgDecodeColumnNotNull
  138                         _tenv_aar3U
  139                         (PGTypeProxy :: PGTypeName "boolean")
  140                         _cpassword_aar48))
  141   pure
  142     (fmap
  143       (\ (vtoken_aar3F, vexpires_aar3G, vid_aar3H, vname_aar3I,
  144           vprename_aar3J, vorcid_aar3K, vaffiliation_aar3L, vurl_aar3M,
  145           vemail_aar3N, vpassword_aar3O, vsite_aar3P, vmember_aar3Q,
  146           vpassword_aar3R)
  147          -> LoginToken
  148               (AccountToken
  149                  (Token vtoken_aar3F vexpires_aar3G)
  150                  (makeSiteAuth
  151                     (makeUserAccount
  152                        (makeAccount
  153                           (PartyRow
  154                              vid_aar3H
  155                              vname_aar3I
  156                              vprename_aar3J
  157                              vorcid_aar3K
  158                              vaffiliation_aar3L
  159                              vurl_aar3M)
  160                           (Account vemail_aar3N)))
  161                     vpassword_aar3O
  162                     (do { cm_aar3S <- vsite_aar3P;
  163                           cm_aar3T <- vmember_aar3Q;
  164                           Just (Access cm_aar3S cm_aar3T) })))
  165               vpassword_aar3R)
  166       mRow)
  167 
  168 -- | Guts of loading a user and its authorizations during each request, when receiving a logged in session token.
  169 -- Find the active session in the sessions table.
  170 -- Join the session account with its party and account information.
  171 -- Join the party with the authorization it has been granted on the databrary site (party 0), if any.
  172 -- Ultimately, a Session object will be created with an access object built up from the user's
  173 -- effective, inherited permissions on the databrary site (party 0).
  174 -- Note that whenever lookupSession is called, we will be in a bootstrap phase of request handling, where
  175 -- the application hasn't attach an identity (MonadHasIdentity) to the context of actions yet.
  176 lookupSession :: MonadDB c m => BS.ByteString -> m (Maybe Session)
  177 lookupSession tok = do
  178   let _tenv_a7Etn = unknownPGTypeEnv
  179   mRow <-
  180     dbQuery1
  181       (mapPrepQuery
  182         ((\ _p_a7Eto ->
  183                        ((Data.String.fromString
  184                           " SELECT \
  185                           \   session.token,session.expires \
  186                           \  ,party.id,party.name,party.prename,party.orcid,party.affiliation,party.url\
  187                           \  ,account.email,account.password\
  188                           \  ,authorize_view.site,authorize_view.member\
  189                           \  ,session.verf,session.superuser\
  190                           \ FROM session\
  191                           \  JOIN party\
  192                           \      JOIN account USING (id)\
  193                           \      LEFT JOIN authorize_view ON account.id = authorize_view.child AND authorize_view.parent = 0\
  194                           \    ON session.account = account.id\
  195                           \ WHERE session.token = $1\
  196                           \ AND expires > CURRENT_TIMESTAMP"),
  197                        [Database.PostgreSQL.Typed.Types.pgEncodeParameter
  198                           _tenv_a7Etn
  199                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  200                              Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  201                           _p_a7Eto]))
  202          tok)
  203                (\ 
  204                   [_ctoken_a7Etp,
  205                    _cexpires_a7Etq,
  206                    _cid_a7Etr,
  207                    _cname_a7Ets,
  208                    _cprename_a7Ett,
  209                    _corcid_a7Etu,
  210                    _caffiliation_a7Etv,
  211                    _curl_a7Etw,
  212                    _cemail_a7Etx,
  213                    _cpassword_a7Ety,
  214                    _csite_a7Etz,
  215                    _cmember_a7EtA,
  216                    _cverf_a7EtB,
  217                    _csuperuser_a7EtC]
  218                   -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  219                         _tenv_a7Etn
  220                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  221                            Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  222                         _ctoken_a7Etp, 
  223                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  224                         _tenv_a7Etn
  225                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  226                            Database.PostgreSQL.Typed.Types.PGTypeName "timestamp with time zone")
  227                         _cexpires_a7Etq, 
  228                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  229                         _tenv_a7Etn
  230                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  231                            Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  232                         _cid_a7Etr, 
  233                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  234                         _tenv_a7Etn
  235                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  236                            Database.PostgreSQL.Typed.Types.PGTypeName "text")
  237                         _cname_a7Ets, 
  238                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  239                         _tenv_a7Etn
  240                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  241                            Database.PostgreSQL.Typed.Types.PGTypeName "text")
  242                         _cprename_a7Ett, 
  243                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  244                         _tenv_a7Etn
  245                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  246                            Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  247                         _corcid_a7Etu, 
  248                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  249                         _tenv_a7Etn
  250                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  251                            Database.PostgreSQL.Typed.Types.PGTypeName "text")
  252                         _caffiliation_a7Etv, 
  253                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  254                         _tenv_a7Etn
  255                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  256                            Database.PostgreSQL.Typed.Types.PGTypeName "text")
  257                         _curl_a7Etw, 
  258                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  259                         _tenv_a7Etn
  260                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  261                            Database.PostgreSQL.Typed.Types.PGTypeName "character varying")
  262                         _cemail_a7Etx, 
  263                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  264                         _tenv_a7Etn
  265                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  266                            Database.PostgreSQL.Typed.Types.PGTypeName "character varying")
  267                         _cpassword_a7Ety, 
  268                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  269                         _tenv_a7Etn
  270                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  271                            Database.PostgreSQL.Typed.Types.PGTypeName "permission")
  272                         _csite_a7Etz, 
  273                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  274                         _tenv_a7Etn
  275                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  276                            Database.PostgreSQL.Typed.Types.PGTypeName "permission")
  277                         _cmember_a7EtA, 
  278                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  279                         _tenv_a7Etn
  280                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  281                            Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  282                         _cverf_a7EtB, 
  283                       Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  284                         _tenv_a7Etn
  285                         (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  286                            Database.PostgreSQL.Typed.Types.PGTypeName "boolean")
  287                         _csuperuser_a7EtC)))
  288   pure
  289     (fmap
  290       (\ (vtoken_a7Esb, vexpires_a7Esc, vid_a7Esd, vname_a7Ese,
  291           vprename_a7Esf, vorcid_a7Esg, vaffiliation_a7Esh, vurl_a7Esi,
  292           vemail_a7Esj, vpassword_a7Esk, vsite_a7Esl, vmember_a7Esm,
  293           vverf_a7Esn, vsuperuser_a7Eso)
  294          -> Session
  295               (AccountToken
  296                  (Token vtoken_a7Esb vexpires_a7Esc)
  297                  (Databrary.Model.Party.SQL.makeSiteAuth
  298                     (Databrary.Model.Party.SQL.makeUserAccount
  299                        -- partially apply makeAccount with party row and account, then feed into makeUserAccount
  300                        (Databrary.Model.Party.SQL.makeAccount
  301                           (PartyRow
  302                              vid_a7Esd
  303                              vname_a7Ese
  304                              vprename_a7Esf
  305                              vorcid_a7Esg
  306                              vaffiliation_a7Esh
  307                              vurl_a7Esi)
  308                           (Account vemail_a7Esj)))
  309                     vpassword_a7Esk
  310                     -- most likely there will be some authorization inherited from a parent user/group to this user
  311                     -- leading to the databrary site (party 0), use that inherited authorization's access values
  312                     (do { cm_a7EsD <- vsite_a7Esl;
  313                           cm_a7EsE <- vmember_a7Esm;
  314                           Just
  315                             (Databrary.Model.Permission.Types.Access cm_a7EsD cm_a7EsE) })))
  316               vverf_a7Esn
  317               vsuperuser_a7Eso)
  318       mRow)
  319 
  320 lookupUpload :: (MonadDB c m, MonadHasIdentity c m) => BS.ByteString -> m (Maybe Upload)
  321 lookupUpload tok = do
  322   let _tenv_aar6E = unknownPGTypeEnv
  323   auth <- peek
  324   -- dbQuery1 $ fmap ($ auth) $(selectQuery selectUpload "$!WHERE upload.token = ${tok} AND expires > CURRENT_TIMESTAMP AND upload.account = ${view auth :: Id Party}")
  325   mRow <- mapRunPrepQuery1
  326       ((\ _p_aar6F _p_aar6G ->
  327                        (Data.String.fromString
  328                           "SELECT upload.token,upload.expires,upload.filename,upload.size FROM upload WHERE upload.token = $1 AND expires > CURRENT_TIMESTAMP AND upload.account = $2",
  329                        [pgEncodeParameter
  330                           _tenv_aar6E (PGTypeProxy :: PGTypeName "bpchar") _p_aar6F,
  331                         pgEncodeParameter
  332                           _tenv_aar6E (PGTypeProxy :: PGTypeName "integer") _p_aar6G],
  333                        [pgBinaryColumn _tenv_aar6E (PGTypeProxy :: PGTypeName "bpchar"),
  334                         pgBinaryColumn
  335                           _tenv_aar6E (PGTypeProxy :: PGTypeName "timestamp with time zone"),
  336                         pgBinaryColumn _tenv_aar6E (PGTypeProxy :: PGTypeName "text"),
  337                         pgBinaryColumn _tenv_aar6E (PGTypeProxy :: PGTypeName "bigint")]))
  338          tok (view auth :: Id Party))
  339                (\
  340                   [_ctoken_aar6H, _cexpires_aar6I, _cfilename_aar6J, _csize_aar6K]
  341                   -> (pgDecodeColumnNotNull
  342                         _tenv_aar6E (PGTypeProxy :: PGTypeName "bpchar") _ctoken_aar6H, 
  343                       pgDecodeColumnNotNull
  344                         _tenv_aar6E
  345                         (PGTypeProxy :: PGTypeName "timestamp with time zone")
  346                         _cexpires_aar6I, 
  347                       pgDecodeColumnNotNull
  348                         _tenv_aar6E (PGTypeProxy :: PGTypeName "text") _cfilename_aar6J, 
  349                       pgDecodeColumnNotNull
  350                         _tenv_aar6E (PGTypeProxy :: PGTypeName "bigint") _csize_aar6K))
  351   pure
  352     (fmap
  353       (\ (vtoken_aar5q, vexpires_aar5r, vfilename_aar5s, vsize_aar5t)
  354          -> makeUpload
  355               (Token vtoken_aar5q vexpires_aar5r) vfilename_aar5s vsize_aar5t
  356               auth)
  357       mRow)
  358 
  359 entropyBase64 :: Int -> Entropy -> IO BS.ByteString
  360 entropyBase64 n e = (convertToBase Base64URLUnpadded :: Bytes -> BS.ByteString) <$> entropyBytes n e
  361 
  362 createToken :: (MonadHas Entropy c m, MonadDB c m) => (Id Token -> DBM a) -> m a
  363 createToken insert = do
  364   e <- peek
  365   let loop = do
  366         tok <- liftIO $ Id <$> entropyBase64 24 e
  367         let _tenv_a7EwN = unknownPGTypeEnv
  368         r <- dbQuery1 -- [pgSQL|SELECT token FROM token WHERE token = ${tok}|]
  369           (mapQuery2
  370             ((\ _p_a7EwO -> 
  371                             (BS.concat
  372                                [Data.String.fromString "SELECT token FROM token WHERE token = ",
  373                                 Database.PostgreSQL.Typed.Types.pgEscapeParameter
  374                                   _tenv_a7EwN
  375                                   (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  376                                      Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  377                                   _p_a7EwO]))
  378               tok)
  379                     (\ [_ctoken_a7EwP]
  380                        -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  381                              _tenv_a7EwN
  382                              (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  383                                 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  384                              _ctoken_a7EwP)))
  385         case r `asTypeOf` Just tok of
  386           Nothing -> insert tok
  387           Just _ -> loop
  388   dbTransaction $ do
  389     _ <- dbExecuteSimple "LOCK TABLE token IN SHARE ROW EXCLUSIVE MODE"
  390     loop
  391 
  392 -- | Delete any prior login token that was generated for this account, then generate a new login token.
  393 -- Used when generating the login token for reset password email. paswd will always be True.
  394 createLoginToken :: (MonadHas Entropy c m, MonadDB c m) => SiteAuth -> Bool -> m LoginToken
  395 createLoginToken auth passwd = do
  396   let (_tenv_a7Ey3, _tenv_a7Ez6) = (unknownPGTypeEnv, unknownPGTypeEnv)
  397   when passwd $ void $ dbExecute -- [pgSQL|DELETE FROM login_token WHERE account = ${view auth :: Id Party} AND password|]
  398     (mapQuery2
  399        ((\ _p_a7Ey4 ->
  400                         (BS.concat
  401                            [Data.String.fromString "DELETE FROM login_token WHERE account = ",
  402                             Database.PostgreSQL.Typed.Types.pgEscapeParameter
  403                               _tenv_a7Ey3
  404                               (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  405                                  Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  406                               _p_a7Ey4,
  407                             Data.String.fromString " AND password"]))
  408           (view auth :: Id Party))
  409        (\[] -> ()))
  410   (tok, ex) <- createToken $ \tok ->
  411     dbQuery1' -- [pgSQL|INSERT INTO login_token (token, account, password) VALUES (${tok}, ${view auth :: Id Party}, ${passwd}) RETURNING token, expires|]
  412      (mapQuery2
  413       ((\ _p_a7Ez7 _p_a7Ez8 _p_a7Ez9 ->
  414                     (BS.concat
  415                        [Data.String.fromString
  416                           "INSERT INTO login_token (token, account, password) VALUES (",
  417                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  418                           _tenv_a7Ez6
  419                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  420                              Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  421                           _p_a7Ez7,
  422                         Data.String.fromString ", ",
  423                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  424                           _tenv_a7Ez6
  425                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  426                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  427                           _p_a7Ez8,
  428                         Data.String.fromString ", ",
  429                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  430                           _tenv_a7Ez6
  431                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  432                              Database.PostgreSQL.Typed.Types.PGTypeName "boolean")
  433                           _p_a7Ez9,
  434                         Data.String.fromString ") RETURNING token, expires"]))
  435         tok (view auth :: Id Party) passwd)
  436             (\[_ctoken_a7Eza, _cexpires_a7Ezb]
  437                -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  438                      _tenv_a7Ez6
  439                      (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  440                         Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  441                      _ctoken_a7Eza, 
  442                    Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  443                      _tenv_a7Ez6
  444                      (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  445                         Database.PostgreSQL.Typed.Types.PGTypeName "timestamp with time zone")
  446                      _cexpires_a7Ezb)))
  447   return $ LoginToken
  448     { loginAccountToken = AccountToken
  449       { accountToken = Token tok ex
  450       , tokenAccount = auth
  451       }
  452     , loginPasswordToken = passwd
  453     }
  454 
  455 sessionDuration :: Bool -> Offset
  456 sessionDuration False = 7*24*60*60
  457 sessionDuration True = 30*60
  458 
  459 createSession :: (MonadHas Entropy c m, MonadDB c m) => SiteAuth -> Bool -> m Session
  460 createSession auth su = do
  461   e <- peek
  462   (tok, ex, verf) <- createToken $ \tok -> do
  463     let _tenv_a7EzQ = unknownPGTypeEnv
  464     verf <- liftIO $ entropyBase64 12 e
  465     dbQuery1' -- [pgSQL|INSERT INTO session (token, expires, account, superuser, verf) VALUES (${tok}, CURRENT_TIMESTAMP + ${sessionDuration su}::interval, ${view auth :: Id Party}, ${su}, ${verf}) RETURNING token, expires, verf|]
  466       (mapQuery2
  467         ((\ _p_a7EzR _p_a7EzS _p_a7EzT _p_a7EzU _p_a7EzV ->
  468                     (BS.concat
  469                        [Data.String.fromString
  470                           "INSERT INTO session (token, expires, account, superuser, verf) VALUES (",
  471                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  472                           _tenv_a7EzQ
  473                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  474                              Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  475                           _p_a7EzR,
  476                         Data.String.fromString ", CURRENT_TIMESTAMP + ",
  477                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  478                           _tenv_a7EzQ
  479                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  480                              Database.PostgreSQL.Typed.Types.PGTypeName "interval")
  481                           _p_a7EzS,
  482                         Data.String.fromString "::interval, ",
  483                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  484                           _tenv_a7EzQ
  485                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  486                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  487                           _p_a7EzT,
  488                         Data.String.fromString ", ",
  489                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  490                           _tenv_a7EzQ
  491                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  492                              Database.PostgreSQL.Typed.Types.PGTypeName "boolean")
  493                           _p_a7EzU,
  494                         Data.String.fromString ", ",
  495                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  496                           _tenv_a7EzQ
  497                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  498                              Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  499                           _p_a7EzV,
  500                         Data.String.fromString ") RETURNING token, expires, verf"]))
  501           tok
  502           (sessionDuration su)
  503           (view auth :: Id Party)
  504           su
  505           verf)
  506         (\ [_ctoken_a7EzW, _cexpires_a7EzX, _cverf_a7EzY]
  507                -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  508                      _tenv_a7EzQ
  509                      (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  510                         Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  511                      _ctoken_a7EzW, 
  512                    Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  513                      _tenv_a7EzQ
  514                      (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  515                         Database.PostgreSQL.Typed.Types.PGTypeName "timestamp with time zone")
  516                      _cexpires_a7EzX, 
  517                    Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  518                      _tenv_a7EzQ
  519                      (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  520                         Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  521                      _cverf_a7EzY)))
  522   return $ Session
  523     { sessionAccountToken = AccountToken
  524       { accountToken = Token tok ex
  525       , tokenAccount = auth
  526       }
  527     , sessionSuperuser = su
  528     , sessionVerf = verf
  529     }
  530 
  531 createUpload :: (MonadHas Entropy c m, MonadDB c m, MonadHasIdentity c m) => Volume -> BS.ByteString -> Int64 -> m Upload
  532 createUpload vol name size = do
  533   auth <- peek
  534   let _tenv_a7EBb = unknownPGTypeEnv
  535   (tok, ex) <- createToken $ \tok ->
  536     dbQuery1' -- [pgSQL|INSERT INTO upload (token, account, volume, filename, size) VALUES (${tok}, ${view auth :: Id Party}, ${volumeId $ volumeRow vol}, ${name}, ${size}) RETURNING token, expires|]
  537       (mapQuery2
  538         ((\ _p_a7EBc _p_a7EBd _p_a7EBe _p_a7EBf _p_a7EBg ->
  539                     (BS.concat
  540                        [Data.String.fromString
  541                           "INSERT INTO upload (token, account, volume, filename, size) VALUES (",
  542                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  543                           _tenv_a7EBb
  544                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  545                              Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  546                           _p_a7EBc,
  547                         Data.String.fromString ", ",
  548                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  549                           _tenv_a7EBb
  550                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  551                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  552                           _p_a7EBd,
  553                         Data.String.fromString ", ",
  554                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  555                           _tenv_a7EBb
  556                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  557                              Database.PostgreSQL.Typed.Types.PGTypeName "integer")
  558                           _p_a7EBe,
  559                         Data.String.fromString ", ",
  560                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  561                           _tenv_a7EBb
  562                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  563                              Database.PostgreSQL.Typed.Types.PGTypeName "text")
  564                           _p_a7EBf,
  565                         Data.String.fromString ", ",
  566                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  567                           _tenv_a7EBb
  568                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  569                              Database.PostgreSQL.Typed.Types.PGTypeName "bigint")
  570                           _p_a7EBg,
  571                         Data.String.fromString ") RETURNING token, expires"]))
  572           tok (view auth :: Id Party) (volumeId $ volumeRow vol) name size)
  573             (\ [_ctoken_a7EBh, _cexpires_a7EBi]
  574                -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  575                      _tenv_a7EBb
  576                      (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  577                         Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  578                      _ctoken_a7EBh, 
  579                    Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  580                      _tenv_a7EBb
  581                      (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  582                         Database.PostgreSQL.Typed.Types.PGTypeName "timestamp with time zone")
  583                      _cexpires_a7EBi)))
  584   return $ Upload
  585     { uploadAccountToken = AccountToken
  586       { accountToken = Token tok ex
  587       , tokenAccount = auth
  588       }
  589     , uploadFilename = name
  590     , uploadSize = size
  591     }
  592 
  593 removeLoginToken :: MonadDB c m => LoginToken -> m Bool
  594 removeLoginToken tok = do
  595   let _tenv_a7EBQ = unknownPGTypeEnv
  596   dbExecute1 -- [pgSQL|DELETE FROM login_token WHERE token = ${view tok :: Id Token}|]
  597    (mapQuery2
  598     ((\ _p_a7EBR ->
  599                     (BS.concat
  600                        [Data.String.fromString "DELETE FROM login_token WHERE token = ",
  601                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  602                           _tenv_a7EBQ
  603                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  604                              Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  605                           _p_a7EBR]))
  606       (view tok :: Id Token))
  607             (\[] -> ()))
  608 
  609 removeSession :: (MonadDB c m) => Session -> m Bool
  610 removeSession tok = do
  611   let _tenv_a7EDh = unknownPGTypeEnv
  612   dbExecute1 -- [pgSQL|DELETE FROM session WHERE token = ${view tok :: Id Token}|]
  613    (mapQuery2
  614     ((\ _p_a7EDi ->
  615                     (BS.concat
  616                        [Data.String.fromString "DELETE FROM session WHERE token = ",
  617                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  618                           _tenv_a7EDh
  619                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  620                              Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  621                           _p_a7EDi]))
  622       (view tok :: Id Token))
  623             (\ [] -> ()))
  624     
  625 removeUploadFile :: (MonadStorage c m) => Upload -> m Bool
  626 removeUploadFile tok = liftIO . removeFile =<< peeks (uploadFile tok)
  627 
  628 removeUpload :: (MonadDB c m, MonadStorage c m) => Upload -> m Bool
  629 removeUpload tok = do
  630   let _tenv_a7ER0 = unknownPGTypeEnv
  631   r <- dbExecute1 --[pgSQL|DELETE FROM upload WHERE token = ${view tok :: Id Token}|]
  632     (mapQuery2
  633       ((\ _p_a7ER1 ->
  634                     (BS.concat
  635                        [Data.String.fromString "DELETE FROM upload WHERE token = ",
  636                         Database.PostgreSQL.Typed.Types.pgEscapeParameter
  637                           _tenv_a7ER0
  638                           (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  639                              Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  640                           _p_a7ER1]))
  641       (view tok :: Id Token))
  642             (\[] -> ()))
  643   when r $ void $ removeUploadFile tok
  644   return r
  645 
  646 cleanTokens :: (MonadDB c m, MonadStorage c m) => m ()
  647 cleanTokens = do
  648   -- toks <- dbQuery $ ($ nobodySiteAuth) <$> $(makeQuery simpleQueryFlags ("DELETE FROM upload WHERE expires < CURRENT_TIMESTAMP RETURNING " ++) (selectOutput selectUpload))
  649   let _tenv_a7EWZ = unknownPGTypeEnv
  650   rows <- dbQuery
  651     (mapQuery2
  652                       (BS.concat
  653                          [Data.String.fromString
  654                             "DELETE FROM upload WHERE expires < CURRENT_TIMESTAMP RETURNING upload.token,upload.expires,upload.filename,upload.size"])
  655               (\
  656                  [_ctoken_a7EX0, _cexpires_a7EX1, _cfilename_a7EX2, _csize_a7EX3]
  657                  -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  658                        _tenv_a7EWZ
  659                        (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  660                           Database.PostgreSQL.Typed.Types.PGTypeName "bpchar")
  661                        _ctoken_a7EX0, 
  662                      Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  663                        _tenv_a7EWZ
  664                        (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  665                           Database.PostgreSQL.Typed.Types.PGTypeName "timestamp with time zone")
  666                        _cexpires_a7EX1, 
  667                      Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  668                        _tenv_a7EWZ
  669                        (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  670                           Database.PostgreSQL.Typed.Types.PGTypeName "text")
  671                        _cfilename_a7EX2, 
  672                      Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull
  673                        _tenv_a7EWZ
  674                        (Database.PostgreSQL.Typed.Types.PGTypeProxy ::
  675                           Database.PostgreSQL.Typed.Types.PGTypeName "bigint")
  676                        _csize_a7EX3)))
  677   let toks =
  678          fmap (\mkTok -> mkTok nobodySiteAuth)
  679           (fmap
  680               (\ (vtoken_a7EVR, vexpires_a7EVS, vfilename_a7EVT, vsize_a7EVU)
  681                  -> makeUpload
  682                       (Token vtoken_a7EVR vexpires_a7EVS) vfilename_a7EVT vsize_a7EVU)
  683               rows)
  684   mapM_ removeUploadFile toks
  685   dbExecute_ "DELETE FROM token WHERE expires < CURRENT_TIMESTAMP"