src/Gargantext/API/Node/File.hs

   1 {-# LANGUAGE AllowAmbiguousTypes     #-}
   2 {-# LANGUAGE TypeOperators     #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-matches -fno-warn-unused-imports #-}
   4
   5 module Gargantext.API.Node.File where
   6
   7 import Control.Lens ((^.))
   8 import qualified Data.ByteString as BS
   9 import qualified Data.ByteString.Lazy as BSL
  10 import qualified Data.MIME.Types as DMT
  11 import Data.Monoid (mempty)
  12 import Data.Swagger
  13 import Data.Text
  14 import Data.Text.Encoding
  15 import qualified Data.Text.IO as TIO
  16 import GHC.Generics (Generic)
  17 import qualified Network.HTTP.Media as M
  18 import Network.Wai.Application.Static
  19 import Servant
  20 import Servant.API.Raw (Raw)
  21 import Servant.Job.Async (JobFunction(..), serveJobsAPI)
  22 import Servant.Job.Core
  23 import Servant.Job.Types
  24 import Servant.Job.Utils (jsonOptions)
  25 import Servant.Server.Internal
  26
  27 import Gargantext.Prelude
  28 import qualified Gargantext.Prelude.Utils as GPU
  29
  30 import Gargantext.Core.Types (TODO)
  31 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
  32 import Gargantext.API.Admin.Settings (HasSettings)
  33 import Gargantext.API.Node.Types
  34 import Gargantext.API.Prelude
  35 import Gargantext.Database.Action.Flow.Types
  36 import Gargantext.Database.Action.Node (mkNodeWithParent)
  37 import Gargantext.Database.Admin.Types.Hyperdata.File
  38 import Gargantext.Database.Admin.Types.Node
  39 import Gargantext.Database.Query.Table.Node (getNodeWith)
  40 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  41 import Gargantext.Database.Schema.Node (node_hyperdata)
  42
  43 data RESPONSE deriving Typeable
  44
  45 instance Accept RESPONSE where
  46   contentType _ = "text" M.// "*"
  47
  48 instance MimeRender RESPONSE BSResponse where
  49   mimeRender _ (BSResponse val) = BSL.fromStrict $ val
  50
  51 type FileApi = Summary "File download"
  52             :> "download"
  53             :> Get '[RESPONSE] (Headers '[Servant.Header "Content-Type" Text] BSResponse)
  54
  55 fileApi :: UserId -> NodeId -> GargServer FileApi
  56 fileApi uId nId = fileDownload uId nId
  57
  58 newtype Contents = Contents BS.ByteString
  59
  60 instance GPU.ReadFile Contents where
  61   readFile' fp = do
  62     c <- BS.readFile fp
  63     pure $ Contents c
  64
  65 newtype BSResponse = BSResponse BS.ByteString
  66   deriving (Generic)
  67
  68 instance ToSchema BSResponse  where
  69   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
  70
  71 fileDownload :: (HasSettings env, FlowCmdM env err m)
  72              => UserId
  73              -> NodeId
  74              -> m (Headers '[Servant.Header "Content-Type" Text] BSResponse)
  75 fileDownload uId nId = do
  76   printDebug "[fileDownload] uId" uId
  77   printDebug "[fileDownload] nId" nId
  78
  79   node <- getNodeWith nId (Proxy :: Proxy HyperdataFile)
  80   let (HyperdataFile { _hff_name = name'
  81                      , _hff_path = path }) = node ^. node_hyperdata
  82
  83   Contents c <- GPU.readFile $ unpack path
  84
  85   let (mMime, _) = DMT.guessType DMT.defaultmtd False $ unpack name'
  86       mime = case mMime of
  87         Just m  -> m
  88         Nothing -> "text/plain"
  89
  90   pure $ addHeader (pack mime) $ BSResponse c
  91
  92   --pure c
  93
  94   -- let settings = embeddedSettings [("", encodeUtf8 c)]
  95
  96   -- Tagged $ staticApp settings
  97
  98   -- let settings = embeddedSettings [("", "hello")]
  99   -- Tagged $ staticApp settings
 100
 101 type FileAsyncApi = Summary "File Async Api"
 102                  :> "file"
 103                  :> "add"
 104                  :> AsyncJobs JobLog '[FormUrlEncoded] NewWithFile JobLog
 105
 106 fileAsyncApi :: UserId -> NodeId -> GargServer FileAsyncApi
 107 fileAsyncApi uId nId =
 108   serveJobsAPI $
 109     JobFunction (\i l ->
 110       let
 111         log' x = do
 112           printDebug "addWithFile" x
 113           liftBase $ l x
 114       in addWithFile uId nId i log')
 115
 116
 117 addWithFile :: (HasSettings env, FlowCmdM env err m)
 118             => UserId
 119             -> NodeId
 120             -> NewWithFile
 121             -> (JobLog -> m ())
 122             -> m JobLog
 123 addWithFile uId nId nwf@(NewWithFile _d _l fName) logStatus = do
 124
 125   printDebug "[addWithFile] Uploading file: " nId
 126   logStatus JobLog { _scst_succeeded = Just 0
 127                    , _scst_failed    = Just 0
 128                    , _scst_remaining = Just 1
 129                    , _scst_events    = Just []
 130                    }
 131
 132   fPath <- GPU.writeFile nwf
 133   printDebug "[addWithFile] File saved as: " fPath
 134
 135   nIds <- mkNodeWithParent NodeFile (Just nId) uId fName
 136
 137   _ <- case nIds of
 138     [nId'] -> do
 139         node <- getNodeWith nId' (Proxy :: Proxy HyperdataFile)
 140         let hl = node ^. node_hyperdata
 141         _ <- updateHyperdata nId' $ hl { _hff_name = fName
 142                                        , _hff_path = pack fPath }
 143
 144         printDebug "[addWithFile] Created node with id: " nId'
 145     _     -> pure ()
 146
 147   printDebug "[addWithFile] File upload finished: " nId
 148   pure $ JobLog { _scst_succeeded = Just 1
 149                 , _scst_failed    = Just 0
 150                 , _scst_remaining = Just 0
 151                 , _scst_events    = Just []
 152                 }