<commit_before>{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes, CPP #-}
module Handler.S3 
       ( getUploadR
       , postUploadR
       , putUploadR
       , getFileR
       , postFileR
       , deleteFileR
       , getFileListR
       , upload -- Internal API
       ) where

import BISocie
import Data.Time
import Data.Int
import qualified Data.ByteString.Lazy as L
import Network.Wai
import Data.List (intercalate)
import System.Directory
import System.FilePath
import Web.Encodings (encodeUrl, decodeUrl)

import qualified Settings (approot, rootRelativePath, s3dir, s3root)
import Settings (widgetFile, cassiusFile)

getUploadR :: Handler RepHtml
getUploadR = do
  (uid,_) <- requireAuth
  defaultLayout $ do
    addCassius $(cassiusFile "s3/s3")
    addWidget $(widgetFile "s3/upload")

-- | upload
--   :: (PersistBackend m, Control.Monad.IO.Class.MonadIO m) =>
--      Key User -> FileInfo -> m (Key FileHeader, String, String, Int64, UTCTime)
upload uid@(UserId uid') fi = do
  now <- liftIO getCurrentTime
  let (name, ext) = splitExtension $ fileName fi
      efname = encodeUrl $ fileName fi
      fsize = L.length $ fileContent fi
  fid@(FileHeaderId fid') <- 
    insert FileHeader 
      { fileHeaderFullname=fileName fi
      , fileHeaderEfname=efname
      , fileHeaderContentType=fileContentType fi
      , fileHeaderFileSize=fsize
      , fileHeaderName=name
      , fileHeaderExtension=ext
      , fileHeaderCreator=uid
      , fileHeaderCreated=now
      }
  let s3dir = Settings.s3dir </> show uid'
      s3fp = s3dir </> show fid'
  liftIO $ do
    createDirectoryIfMissing True s3dir
    L.writeFile s3fp (fileContent fi)
  return (fid, fileName fi, ext, fsize, now)
  
postUploadR :: Handler RepXml
postUploadR = do
  (uid, _) <- requireAuth
  mfi <- lookupFile "upfile"
  case mfi of
    Nothing -> invalidArgs ["upload file is required."]
    Just fi -> do
      r <- getUrlRender
      (fid@(FileHeaderId f), name, ext, fsize, cdate) <- runDB $ upload uid fi
      cacheSeconds 10 -- FIXME
      let rf = r $ FileR uid fid
      fmap RepXml $ hamletToContent
#if GHC7
                      [xhamlet|
#else
                      [$xhamlet|
#endif
%file
  %fhid $show.fid$
  %name $name$
  %ext $ext$
  %size $show.fsize$
  %cdate $show.cdate$
  %uri $rf$
|]

putUploadR :: Handler RepHtml
putUploadR = do
  (uid, _) <- requireAuth
  mfi <- lookupFile "upfile"
  case mfi of
    Nothing -> invalidArgs ["upload file is required."]
    Just fi -> do
      (fid, _, _, _, _) <- runDB $ upload uid fi
      sendResponseCreated $ FileR uid fid


getFileR :: UserId -> FileHeaderId -> Handler RepHtml
getFileR uid@(UserId uid') fid@(FileHeaderId fid') = do
  h <- runDB $ get404 fid
  let UserId id = fileHeaderCreator h
      s3dir = Settings.s3dir </> show uid'
      s3fp = s3dir </> show fid'
  b <- liftIO $ L.readFile s3fp
  setHeader "Content-Type" $ fileHeaderContentType h
  setHeader "Content-Disposition" $ "attachment; filename=" ++ fileHeaderEfname h
  return $ RepHtml $ ResponseLBS b

postFileR :: UserId -> FileHeaderId -> Handler RepXml
postFileR uid@(UserId uid') fid@(FileHeaderId fid') = do
  (uid, _) <- requireAuth
  _method <- lookupPostParam "_method"
  case _method of
    Just "delete" -> deleteFileR uid fid
    Nothing       -> invalidArgs ["The possible values of '_method' are delete."]

deleteFileR :: UserId -> FileHeaderId -> Handler RepXml
deleteFileR uid@(UserId uid') fid@(FileHeaderId fid') = do
  (uid'', _) <- requireAuth
  if uid/=uid''
    then
    invalidArgs ["You couldn't delete this resource."]
    else do
    r <- getUrlRender
    runDB $ delete fid
    let s3dir = Settings.s3dir </> show uid'
        s3fp = s3dir </> show fid'
        rf = r $ FileR uid fid
    liftIO $ removeFile s3fp
    fmap RepXml $ hamletToContent
#if GHC7
                  [xhamlet|
#else
                  [$xhamlet|
#endif
%deleted
  %uri $rf$
|]

getFileListR :: UserId -> Handler RepJson
getFileListR uid@(UserId uid') = do
  render <- getUrlRender
  files <- runDB $ selectList [FileHeaderCreatorEq uid] [FileHeaderCreatedDesc] 0 0
  cacheSeconds 10 -- FIXME
  jsonToRepJson $ jsonMap [("files", jsonList $ map (go render) files)]
  where
    go r (fid@(FileHeaderId fid'), f@FileHeader
               { fileHeaderFullname = name
               , fileHeaderExtension = ext
               , fileHeaderFileSize = size
               , fileHeaderCreated = cdate
               }) = 
      jsonMap [ ("name", jsonScalar name)
              , ("ext" , jsonScalar ext)
              , ("size", jsonScalar $ show size)
              , ("cdate", jsonScalar $ show cdate)<commit_msg>add requireAuth to get FileList of S3.<commit_after>{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes, CPP #-}
module Handler.S3 
       ( getUploadR
       , postUploadR
       , putUploadR
       , getFileR
       , postFileR
       , deleteFileR
       , getFileListR
       , upload -- Internal API
       ) where

import BISocie
import Data.Time
import Data.Int
import qualified Data.ByteString.Lazy as L
import Network.Wai
import Data.List (intercalate)
import System.Directory
import System.FilePath
import Web.Encodings (encodeUrl, decodeUrl)

import qualified Settings (approot, rootRelativePath, s3dir, s3root)
import Settings (widgetFile, cassiusFile)

getUploadR :: Handler RepHtml
getUploadR = do
  (uid,_) <- requireAuth
  defaultLayout $ do
    addCassius $(cassiusFile "s3/s3")
    addWidget $(widgetFile "s3/upload")

-- | upload
--   :: (PersistBackend m, Control.Monad.IO.Class.MonadIO m) =>
--      Key User -> FileInfo -> m (Key FileHeader, String, String, Int64, UTCTime)
upload uid@(UserId uid') fi = do
  now <- liftIO getCurrentTime
  let (name, ext) = splitExtension $ fileName fi
      efname = encodeUrl $ fileName fi
      fsize = L.length $ fileContent fi
  fid@(FileHeaderId fid') <- 
    insert FileHeader 
      { fileHeaderFullname=fileName fi
      , fileHeaderEfname=efname
      , fileHeaderContentType=fileContentType fi
      , fileHeaderFileSize=fsize
      , fileHeaderName=name
      , fileHeaderExtension=ext
      , fileHeaderCreator=uid
      , fileHeaderCreated=now
      }
  let s3dir = Settings.s3dir </> show uid'
      s3fp = s3dir </> show fid'
  liftIO $ do
    createDirectoryIfMissing True s3dir
    L.writeFile s3fp (fileContent fi)
  return (fid, fileName fi, ext, fsize, now)
  
postUploadR :: Handler RepXml
postUploadR = do
  (uid, _) <- requireAuth
  mfi <- lookupFile "upfile"
  case mfi of
    Nothing -> invalidArgs ["upload file is required."]
    Just fi -> do
      r <- getUrlRender
      (fid@(FileHeaderId f), name, ext, fsize, cdate) <- runDB $ upload uid fi
      cacheSeconds 10 -- FIXME
      let rf = r $ FileR uid fid
      fmap RepXml $ hamletToContent
#if GHC7
                      [xhamlet|
#else
                      [$xhamlet|
#endif
%file
  %fhid $show.fid$
  %name $name$
  %ext $ext$
  %size $show.fsize$
  %cdate $show.cdate$
  %uri $rf$
|]

putUploadR :: Handler RepHtml
putUploadR = do
  (uid, _) <- requireAuth
  mfi <- lookupFile "upfile"
  case mfi of
    Nothing -> invalidArgs ["upload file is required."]
    Just fi -> do
      (fid, _, _, _, _) <- runDB $ upload uid fi
      sendResponseCreated $ FileR uid fid


getFileR :: UserId -> FileHeaderId -> Handler RepHtml
getFileR uid@(UserId uid') fid@(FileHeaderId fid') = do
  h <- runDB $ get404 fid
  let UserId id = fileHeaderCreator h
      s3dir = Settings.s3dir </> show uid'
      s3fp = s3dir </> show fid'
  b <- liftIO $ L.readFile s3fp
  setHeader "Content-Type" $ fileHeaderContentType h
  setHeader "Content-Disposition" $ "attachment; filename=" ++ fileHeaderEfname h
  return $ RepHtml $ ResponseLBS b

postFileR :: UserId -> FileHeaderId -> Handler RepXml
postFileR uid@(UserId uid') fid@(FileHeaderId fid') = do
  (uid, _) <- requireAuth
  _method <- lookupPostParam "_method"
  case _method of
    Just "delete" -> deleteFileR uid fid
    Nothing       -> invalidArgs ["The possible values of '_method' are delete."]

deleteFileR :: UserId -> FileHeaderId -> Handler RepXml
deleteFileR uid@(UserId uid') fid@(FileHeaderId fid') = do
  (uid'', _) <- requireAuth
  if uid/=uid''
    then
    invalidArgs ["You couldn't delete this resource."]
    else do
    r <- getUrlRender
    runDB $ delete fid
    let s3dir = Settings.s3dir </> show uid'
        s3fp = s3dir </> show fid'
        rf = r $ FileR uid fid
    liftIO $ removeFile s3fp
    fmap RepXml $ hamletToContent
#if GHC7
                  [xhamlet|
#else
                  [$xhamlet|
#endif
%deleted
  %uri $rf$
|]

getFileListR :: UserId -> Handler RepJson
getFileListR uid@(UserId uid') = do
  _ <- requireAuth
  render <- getUrlRender
  files <- runDB $ selectList [FileHeaderCreatorEq uid] [FileHeaderCreatedDesc] 0 0
  cacheSeconds 10 -- FIXME
  jsonToRepJson $ jsonMap [("files", jsonList $ map (go render) files)]
  where
    go r (fid@(FileHeaderId fid'), f@FileHeader
               { fileHeaderFullname = name
               , fileHeaderExtension = ext
               , fileHeaderFileSize = size
               , fileHeaderCreated = cdate
               }) = 
      jsonMap [ ("name", jsonScalar name)
              , ("ext" , jsonScalar ext)
              , ("size", jsonScalar $ show size)
              , ("cdate", jsonScalar $ show cdate)
{'fraction_non_alphanumeric': 0.10502136752136752, 'fraction_numerical': 0.007585470085470085, 'mean_word_length': 2.6883372734436564, 'pattern_counts': {'":': 0, '<': 52, '<?xml version=': 0, '>': 47, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '708448', 'n_tokens_mistral': 3077, 'n_tokens_neox': 3038, 'n_words': 880}