src/Gargantext/API.hs

   1 {-|
   2 Module      : Gargantext.API
   3 Description : REST API declaration
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Main (RESTful) API of the instance Gargantext.
  11
  12 The Garg-API is typed to derive the documentation, the mock and tests.
  13
  14 This API is indeed typed in order to be able to derive both the server
  15 and the client sides.
  16
  17 The Garg-API-Monad enables:
  18   - Security (WIP)
  19   - Features (WIP)
  20   - Database connection (long term)
  21   - In Memory stack management (short term)
  22   - Logs (WIP)
  23
  24 Thanks to Yann Esposito for our discussions at the start and to Nicolas
  25 Pouillard (who mainly made it).
  26
  27 -}
  28
  29 {-# LANGUAGE BangPatterns         #-}
  30 {-# LANGUAGE NumericUnderscores   #-}
  31 {-# LANGUAGE ScopedTypeVariables  #-}
  32 {-# LANGUAGE TypeOperators        #-}
  33 module Gargantext.API
  34       where
  35
  36 import Control.Concurrent
  37 import Control.Exception (catch, finally, SomeException{-, displayException, IOException-})
  38 import Control.Lens
  39 import Control.Monad.Except
  40 import Control.Monad.Reader (runReaderT)
  41 import Data.Either
  42 import Data.Foldable (foldlM)
  43 import Data.List (lookup)
  44 import Data.Text (pack)
  45 import Data.Text.Encoding (encodeUtf8)
  46 import Data.Text.IO (putStrLn)
  47 import Data.Validity
  48 import GHC.Base (Applicative)
  49 import GHC.Generics (Generic)
  50 import Gargantext.API.Admin.Auth.Types (AuthContext)
  51 import Gargantext.API.Admin.EnvTypes (Env)
  52 import Gargantext.API.Admin.Settings (newEnv)
  53 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
  54 import Gargantext.API.EKG
  55 import Gargantext.API.Ngrams (saveNodeStoryImmediate)
  56 import Gargantext.API.Routes
  57 import Gargantext.API.Server (server)
  58 import Gargantext.Core.NodeStory
  59 -- import Gargantext.Database.Prelude (Cmd)
  60 -- import Gargantext.Database.Action.Metrics.NgramsByContext (refreshNgramsMaterialized)
  61 import Gargantext.Prelude hiding (putStrLn)
  62 import Network.HTTP.Types hiding (Query)
  63 import Network.Wai
  64 import Network.Wai.Handler.Warp hiding (defaultSettings)
  65 import Network.Wai.Middleware.Cors
  66 import Network.Wai.Middleware.RequestLogger
  67 import Paths_gargantext (getDataDir)
  68 import Servant
  69 import System.FilePath
  70 import qualified Gargantext.Database.Prelude as DB
  71 import qualified System.Cron.Schedule as Cron
  72
  73 data Mode = Dev | Mock | Prod
  74   deriving (Show, Read, Generic)
  75
  76 -- | startGargantext takes as parameters port number and Ini file.
  77 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
  78 startGargantext mode port file = do
  79   env <- newEnv port file
  80   runDbCheck env
  81   portRouteInfo port
  82   app <- makeApp env
  83   mid <- makeDevMiddleware mode
  84   periodicActions <- schedulePeriodicActions env
  85   run port (mid app) `finally` stopGargantext env periodicActions
  86
  87   where runDbCheck env = do
  88           r <- runExceptT (runReaderT DB.dbCheck env) `catch`
  89             (\(_ :: SomeException) -> return $ Right False)
  90           case r of
  91             Right True -> return ()
  92             _ -> panic $
  93               "You must run 'gargantext-init " <> pack file <>
  94               "' before running gargantext-server (only the first time)."
  95
  96 portRouteInfo :: PortNumber -> IO ()
  97 portRouteInfo port = do
  98   putStrLn "      ----Main Routes-----      "
  99   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
 100   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 101
 102 -- | Stops the gargantext server and cancels all the periodic actions
 103 -- scheduled to run up to that point.
 104 -- TODO clean this Monad condition (more generic) ?
 105 stopGargantext :: HasNodeStoryImmediateSaver env => env -> [ThreadId] -> IO ()
 106 stopGargantext env scheduledPeriodicActions = do
 107   forM_ scheduledPeriodicActions killThread
 108   putStrLn "----- Stopping gargantext -----"
 109   runReaderT saveNodeStoryImmediate env
 110
 111 {-
 112 startGargantextMock :: PortNumber -> IO ()
 113 startGargantextMock port = do
 114   portRouteInfo port
 115   application <- makeMockApp . MockEnv $ FireWall False
 116   run port application
 117 -}
 118
 119 -- | Schedules all sorts of useful periodic actions to be run while
 120 -- the server is alive accepting requests.
 121 schedulePeriodicActions :: DB.CmdCommon env => env -> IO [ThreadId]
 122 schedulePeriodicActions _env =
 123   -- Add your scheduled actions here.
 124   let actions = [
 125           -- refreshDBViews
 126         ]
 127   in foldlM (\ !acc action -> (`mappend` acc) <$> Cron.execSchedule action) [] actions
 128
 129 {-
 130   where
 131
 132     refreshDBViews :: Cron.Schedule ()
 133     refreshDBViews = do
 134       let doRefresh = do
 135             res <- DB.runCmd env (refreshNgramsMaterialized :: Cmd IOException ())
 136             case res of
 137               Left e   -> liftIO $ putStrLn $ pack ("Refreshing Ngrams materialized view failed: " <> displayException e)
 138               Right () ->  do
 139                 _ <- liftIO $ putStrLn $ pack "Refresh Index Database done"
 140                 pure ()
 141       Cron.addJob doRefresh "* 2 * * *"
 142 -}
 143
 144 ----------------------------------------------------------------------
 145
 146 fireWall :: Applicative f => Request -> FireWall -> f Bool
 147 fireWall req fw = do
 148     let origin = lookup "Origin" (requestHeaders req)
 149     let host   = lookup "Host"   (requestHeaders req)
 150
 151     if  origin == Just (encodeUtf8 "http://localhost:8008")
 152        && host == Just (encodeUtf8 "localhost:3000")
 153        || (not $ unFireWall fw)
 154
 155        then pure True
 156        else pure False
 157
 158 {-
 159 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 160 makeMockApp :: MockEnv -> IO Application
 161 makeMockApp env = do
 162     let serverApp = appMock
 163
 164     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 165     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 166     let checkOriginAndHost app req resp = do
 167             blocking <- fireWall req (env ^. menv_firewall)
 168             case blocking  of
 169                 True  -> app req resp
 170                 False -> resp ( responseLBS status401 []
 171                               "Invalid Origin or Host header")
 172
 173     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 174 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 175             { corsOrigins        = Nothing --  == /*
 176             , corsMethods        = [ methodGet   , methodPost   , methodPut
 177                                    , methodDelete, methodOptions, methodHead]
 178             , corsRequestHeaders = ["authorization", "content-type"]
 179             , corsExposedHeaders = Nothing
 180             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 181             , corsVaryOrigin     = False
 182             , corsRequireOrigin  = False
 183             , corsIgnoreFailures = False
 184             }
 185
 186     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 187     --          $ Warp.defaultSettings
 188
 189     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 190     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 191 -}
 192
 193
 194 makeDevMiddleware :: Mode -> IO Middleware
 195 makeDevMiddleware mode = do
 196 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 197 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 198 --    let checkOriginAndHost app req resp = do
 199 --            blocking <- fireWall req (env ^. menv_firewall)
 200 --            case blocking  of
 201 --                True  -> app req resp
 202 --                False -> resp ( responseLBS status401 []
 203 --                              "Invalid Origin or Host header")
 204 --
 205     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 206 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 207             { corsOrigins        = Nothing --  == /*
 208             , corsMethods        = [ methodGet   , methodPost   , methodPut
 209                                    , methodDelete, methodOptions, methodHead]
 210             , corsRequestHeaders = ["authorization", "content-type"]
 211             , corsExposedHeaders = Nothing
 212             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 213             , corsVaryOrigin     = False
 214             , corsRequireOrigin  = False
 215             , corsIgnoreFailures = False
 216             }
 217
 218     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 219     --          $ Warp.defaultSettings
 220
 221     --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
 222     case mode of
 223       Prod -> pure $ logStdout . corsMiddleware
 224       _    -> pure $ logStdoutDev . corsMiddleware
 225
 226 ---------------------------------------------------------------------
 227 -- | API Global
 228 ---------------------------------------------------------------------
 229
 230 ---------------------------
 231
 232
 233 -- TODO-SECURITY admin only: withAdmin
 234 -- Question: How do we mark admins?
 235 {-
 236 serverGargAdminAPI :: GargServer GargAdminAPI
 237 serverGargAdminAPI =  roots
 238                  :<|> nodesAPI
 239 -}
 240
 241 ---------------------------------------------------------------------
 242 --gargMock :: Server GargAPI
 243 --gargMock = mock apiGarg Proxy
 244 ---------------------------------------------------------------------
 245
 246 makeApp :: Env -> IO Application
 247 makeApp env = do
 248   serv <- server env
 249   (ekgStore, ekgMid) <- newEkgStore api
 250   ekgDir <- (</> "ekg-assets") <$> getDataDir
 251   return $ ekgMid $ serveWithContext apiWithEkg cfg
 252     (ekgServer ekgDir ekgStore :<|> serv)
 253   where
 254     cfg :: Servant.Context AuthContext
 255     cfg = env ^. settings . jwtSettings
 256        :. env ^. settings . cookieSettings
 257     -- :. authCheck env
 258        :. EmptyContext
 259
 260 --appMock :: Application
 261 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 262 ---------------------------------------------------------------------
 263 api :: Proxy API
 264 api  = Proxy
 265
 266 apiWithEkg :: Proxy (EkgAPI :<|> API)
 267 apiWithEkg = Proxy
 268
 269 apiGarg :: Proxy GargAPI
 270 apiGarg  = Proxy
 271 ---------------------------------------------------------------------
 272
 273 {- UNUSED
 274 --import GHC.Generics (D1, Meta (..), Rep, Generic)
 275 --import GHC.TypeLits (AppendSymbol, Symbol)
 276 ---------------------------------------------------------------------
 277 -- Type Family for the Documentation
 278 type family TypeName (x :: *) :: Symbol where
 279     TypeName Int  = "Int"
 280     TypeName Text = "Text"
 281     TypeName x    = GenericTypeName x (Rep x ())
 282
 283 type family GenericTypeName t (r :: *) :: Symbol where
 284     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 285
 286 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 287 -}