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)
  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.GargDB (refreshNgramsMaterializedView)
  60 import Gargantext.Prelude hiding (putStrLn)
  61 import Network.HTTP.Types hiding (Query)
  62 import Network.Wai
  63 import Network.Wai.Handler.Warp hiding (defaultSettings)
  64 import Network.Wai.Middleware.Cors
  65 import Network.Wai.Middleware.RequestLogger
  66 import Paths_gargantext (getDataDir)
  67 import Servant
  68 import System.FilePath
  69 import qualified Gargantext.Database.Prelude as DB
  70 import qualified System.Cron.Schedule as Cron
  71
  72 data Mode = Dev | Mock | Prod
  73   deriving (Show, Read, Generic)
  74
  75 -- | startGargantext takes as parameters port number and Ini file.
  76 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
  77 startGargantext mode port file = do
  78   env <- newEnv port file
  79   runDbCheck env
  80   portRouteInfo port
  81   app <- makeApp env
  82   mid <- makeDevMiddleware mode
  83   periodicActions <- schedulePeriodicActions env
  84   run port (mid app) `finally` stopGargantext env periodicActions
  85
  86   where runDbCheck env = do
  87           r <- runExceptT (runReaderT DB.dbCheck env) `catch`
  88             (\(_ :: SomeException) -> return $ Right False)
  89           case r of
  90             Right True -> return ()
  91             _ -> panic $
  92               "You must run 'gargantext-init " <> pack file <>
  93               "' before running gargantext-server (only the first time)."
  94
  95 portRouteInfo :: PortNumber -> IO ()
  96 portRouteInfo port = do
  97   putStrLn "      ----Main Routes-----      "
  98   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
  99   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 100
 101 -- | Stops the gargantext server and cancels all the periodic actions
 102 -- scheduled to run up to that point.
 103 -- TODO clean this Monad condition (more generic) ?
 104 stopGargantext :: HasNodeStoryImmediateSaver env => env -> [ThreadId] -> IO ()
 105 stopGargantext env scheduledPeriodicActions = do
 106   forM_ scheduledPeriodicActions killThread
 107   putStrLn "----- Stopping gargantext -----"
 108   runReaderT saveNodeStoryImmediate env
 109
 110 {-
 111 startGargantextMock :: PortNumber -> IO ()
 112 startGargantextMock port = do
 113   portRouteInfo port
 114   application <- makeMockApp . MockEnv $ FireWall False
 115   run port application
 116 -}
 117
 118 -- | Schedules all sorts of useful periodic actions to be run while
 119 -- the server is alive accepting requests.
 120 schedulePeriodicActions :: DB.CmdCommon env => env -> IO [ThreadId]
 121 schedulePeriodicActions env =
 122   -- Add your scheduled actions here.
 123   let actions = [
 124           refreshDBViews
 125         ]
 126   in foldlM (\ !acc action -> (`mappend` acc) <$> Cron.execSchedule action) [] actions
 127
 128   where
 129
 130     refreshDBViews :: Cron.Schedule ()
 131     refreshDBViews = do
 132       let doRefresh = do
 133             res <- DB.runCmd env refreshNgramsMaterializedView
 134             case res of
 135               Left e   -> liftIO $ putStrLn $ pack ("Refreshing Ngrams materialized view failed: " <> displayException e)
 136               Right () -> pure ()
 137       Cron.addJob doRefresh "5 * * * *"
 138
 139 ----------------------------------------------------------------------
 140
 141 fireWall :: Applicative f => Request -> FireWall -> f Bool
 142 fireWall req fw = do
 143     let origin = lookup "Origin" (requestHeaders req)
 144     let host   = lookup "Host"   (requestHeaders req)
 145
 146     if  origin == Just (encodeUtf8 "http://localhost:8008")
 147        && host == Just (encodeUtf8 "localhost:3000")
 148        || (not $ unFireWall fw)
 149
 150        then pure True
 151        else pure False
 152
 153 {-
 154 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 155 makeMockApp :: MockEnv -> IO Application
 156 makeMockApp env = do
 157     let serverApp = appMock
 158
 159     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 160     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 161     let checkOriginAndHost app req resp = do
 162             blocking <- fireWall req (env ^. menv_firewall)
 163             case blocking  of
 164                 True  -> app req resp
 165                 False -> resp ( responseLBS status401 []
 166                               "Invalid Origin or Host header")
 167
 168     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 169 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 170             { corsOrigins        = Nothing --  == /*
 171             , corsMethods        = [ methodGet   , methodPost   , methodPut
 172                                    , methodDelete, methodOptions, methodHead]
 173             , corsRequestHeaders = ["authorization", "content-type"]
 174             , corsExposedHeaders = Nothing
 175             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 176             , corsVaryOrigin     = False
 177             , corsRequireOrigin  = False
 178             , corsIgnoreFailures = False
 179             }
 180
 181     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 182     --          $ Warp.defaultSettings
 183
 184     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 185     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 186 -}
 187
 188
 189 makeDevMiddleware :: Mode -> IO Middleware
 190 makeDevMiddleware mode = do
 191 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 192 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 193 --    let checkOriginAndHost app req resp = do
 194 --            blocking <- fireWall req (env ^. menv_firewall)
 195 --            case blocking  of
 196 --                True  -> app req resp
 197 --                False -> resp ( responseLBS status401 []
 198 --                              "Invalid Origin or Host header")
 199 --
 200     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 201 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 202             { corsOrigins        = Nothing --  == /*
 203             , corsMethods        = [ methodGet   , methodPost   , methodPut
 204                                    , methodDelete, methodOptions, methodHead]
 205             , corsRequestHeaders = ["authorization", "content-type"]
 206             , corsExposedHeaders = Nothing
 207             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 208             , corsVaryOrigin     = False
 209             , corsRequireOrigin  = False
 210             , corsIgnoreFailures = False
 211             }
 212
 213     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 214     --          $ Warp.defaultSettings
 215
 216     --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
 217     case mode of
 218       Prod -> pure $ logStdout . corsMiddleware
 219       _    -> pure $ logStdoutDev . corsMiddleware
 220
 221 ---------------------------------------------------------------------
 222 -- | API Global
 223 ---------------------------------------------------------------------
 224
 225 ---------------------------
 226
 227
 228 -- TODO-SECURITY admin only: withAdmin
 229 -- Question: How do we mark admins?
 230 {-
 231 serverGargAdminAPI :: GargServer GargAdminAPI
 232 serverGargAdminAPI =  roots
 233                  :<|> nodesAPI
 234 -}
 235
 236 ---------------------------------------------------------------------
 237 --gargMock :: Server GargAPI
 238 --gargMock = mock apiGarg Proxy
 239 ---------------------------------------------------------------------
 240
 241 makeApp :: Env -> IO Application
 242 makeApp env = do
 243   serv <- server env
 244   (ekgStore, ekgMid) <- newEkgStore api
 245   ekgDir <- (</> "ekg-assets") <$> getDataDir
 246   return $ ekgMid $ serveWithContext apiWithEkg cfg
 247     (ekgServer ekgDir ekgStore :<|> serv)
 248   where
 249     cfg :: Servant.Context AuthContext
 250     cfg = env ^. settings . jwtSettings
 251        :. env ^. settings . cookieSettings
 252     -- :. authCheck env
 253        :. EmptyContext
 254
 255 --appMock :: Application
 256 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 257 ---------------------------------------------------------------------
 258 api :: Proxy API
 259 api  = Proxy
 260
 261 apiWithEkg :: Proxy (EkgAPI :<|> API)
 262 apiWithEkg = Proxy
 263
 264 apiGarg :: Proxy GargAPI
 265 apiGarg  = Proxy
 266 ---------------------------------------------------------------------
 267
 268 {- UNUSED
 269 --import GHC.Generics (D1, Meta (..), Rep, Generic)
 270 --import GHC.TypeLits (AppendSymbol, Symbol)
 271 ---------------------------------------------------------------------
 272 -- Type Family for the Documentation
 273 type family TypeName (x :: *) :: Symbol where
 274     TypeName Int  = "Int"
 275     TypeName Text = "Text"
 276     TypeName x    = GenericTypeName x (Rep x ())
 277
 278 type family GenericTypeName t (r :: *) :: Symbol where
 279     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 280
 281 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 282 -}