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   where
 130
 131     refreshDBViews :: Cron.Schedule ()
 132     refreshDBViews = do
 133       let doRefresh = do
 134             res <- DB.runCmd env (refreshNgramsMaterialized :: Cmd IOException ())
 135             case res of
 136               Left e   -> liftIO $ putStrLn $ pack ("Refreshing Ngrams materialized view failed: " <> displayException e)
 137               Right () ->  do
 138                 _ <- liftIO $ putStrLn $ pack "Refresh Index Database done"
 139                 pure ()
 140       Cron.addJob doRefresh "* 2 * * *"
 141
 142 ----------------------------------------------------------------------
 143
 144 fireWall :: Applicative f => Request -> FireWall -> f Bool
 145 fireWall req fw = do
 146     let origin = lookup "Origin" (requestHeaders req)
 147     let host   = lookup "Host"   (requestHeaders req)
 148
 149     if  origin == Just (encodeUtf8 "http://localhost:8008")
 150        && host == Just (encodeUtf8 "localhost:3000")
 151        || (not $ unFireWall fw)
 152
 153        then pure True
 154        else pure False
 155
 156 {-
 157 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 158 makeMockApp :: MockEnv -> IO Application
 159 makeMockApp env = do
 160     let serverApp = appMock
 161
 162     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 163     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 164     let checkOriginAndHost app req resp = do
 165             blocking <- fireWall req (env ^. menv_firewall)
 166             case blocking  of
 167                 True  -> app req resp
 168                 False -> resp ( responseLBS status401 []
 169                               "Invalid Origin or Host header")
 170
 171     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 172 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 173             { corsOrigins        = Nothing --  == /*
 174             , corsMethods        = [ methodGet   , methodPost   , methodPut
 175                                    , methodDelete, methodOptions, methodHead]
 176             , corsRequestHeaders = ["authorization", "content-type"]
 177             , corsExposedHeaders = Nothing
 178             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 179             , corsVaryOrigin     = False
 180             , corsRequireOrigin  = False
 181             , corsIgnoreFailures = False
 182             }
 183
 184     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 185     --          $ Warp.defaultSettings
 186
 187     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 188     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 189 -}
 190
 191
 192 makeDevMiddleware :: Mode -> IO Middleware
 193 makeDevMiddleware mode = do
 194 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 195 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 196 --    let checkOriginAndHost app req resp = do
 197 --            blocking <- fireWall req (env ^. menv_firewall)
 198 --            case blocking  of
 199 --                True  -> app req resp
 200 --                False -> resp ( responseLBS status401 []
 201 --                              "Invalid Origin or Host header")
 202 --
 203     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 204 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 205             { corsOrigins        = Nothing --  == /*
 206             , corsMethods        = [ methodGet   , methodPost   , methodPut
 207                                    , methodDelete, methodOptions, methodHead]
 208             , corsRequestHeaders = ["authorization", "content-type"]
 209             , corsExposedHeaders = Nothing
 210             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 211             , corsVaryOrigin     = False
 212             , corsRequireOrigin  = False
 213             , corsIgnoreFailures = False
 214             }
 215
 216     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 217     --          $ Warp.defaultSettings
 218
 219     --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
 220     case mode of
 221       Prod -> pure $ logStdout . corsMiddleware
 222       _    -> pure $ logStdoutDev . corsMiddleware
 223
 224 ---------------------------------------------------------------------
 225 -- | API Global
 226 ---------------------------------------------------------------------
 227
 228 ---------------------------
 229
 230
 231 -- TODO-SECURITY admin only: withAdmin
 232 -- Question: How do we mark admins?
 233 {-
 234 serverGargAdminAPI :: GargServer GargAdminAPI
 235 serverGargAdminAPI =  roots
 236                  :<|> nodesAPI
 237 -}
 238
 239 ---------------------------------------------------------------------
 240 --gargMock :: Server GargAPI
 241 --gargMock = mock apiGarg Proxy
 242 ---------------------------------------------------------------------
 243
 244 makeApp :: Env -> IO Application
 245 makeApp env = do
 246   serv <- server env
 247   (ekgStore, ekgMid) <- newEkgStore api
 248   ekgDir <- (</> "ekg-assets") <$> getDataDir
 249   return $ ekgMid $ serveWithContext apiWithEkg cfg
 250     (ekgServer ekgDir ekgStore :<|> serv)
 251   where
 252     cfg :: Servant.Context AuthContext
 253     cfg = env ^. settings . jwtSettings
 254        :. env ^. settings . cookieSettings
 255     -- :. authCheck env
 256        :. EmptyContext
 257
 258 --appMock :: Application
 259 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 260 ---------------------------------------------------------------------
 261 api :: Proxy API
 262 api  = Proxy
 263
 264 apiWithEkg :: Proxy (EkgAPI :<|> API)
 265 apiWithEkg = Proxy
 266
 267 apiGarg :: Proxy GargAPI
 268 apiGarg  = Proxy
 269 ---------------------------------------------------------------------
 270
 271 {- UNUSED
 272 --import GHC.Generics (D1, Meta (..), Rep, Generic)
 273 --import GHC.TypeLits (AppendSymbol, Symbol)
 274 ---------------------------------------------------------------------
 275 -- Type Family for the Documentation
 276 type family TypeName (x :: *) :: Symbol where
 277     TypeName Int  = "Int"
 278     TypeName Text = "Text"
 279     TypeName x    = GenericTypeName x (Rep x ())
 280
 281 type family GenericTypeName t (r :: *) :: Symbol where
 282     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 283
 284 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 285 -}