src/Gargantext/API/Node/File.hs

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