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 ScopedTypeVariables  #-}
  30 {-# LANGUAGE TypeOperators        #-}
  31 module Gargantext.API
  32       where
  33
  34 import Control.Exception (finally)
  35 import Control.Lens
  36 import Control.Monad.Reader (runReaderT)
  37 import Data.List (lookup)
  38 import Data.Text.Encoding (encodeUtf8)
  39 import Data.Text.IO (putStrLn)
  40 import Data.Validity
  41 import GHC.Base (Applicative)
  42 import GHC.Generics (Generic)
  43 import Gargantext.API.Admin.Auth.Types (AuthContext)
  44 import Gargantext.API.Admin.Settings (newEnv)
  45 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
  46 import Gargantext.API.EKG
  47 import Gargantext.API.Ngrams (saveNodeStory)
  48 import Gargantext.API.Prelude
  49 import Gargantext.API.Routes
  50 import Gargantext.API.Server (server)
  51 import Gargantext.Core.NodeStory
  52 import Gargantext.Prelude hiding (putStrLn)
  53 import Network.HTTP.Types hiding (Query)
  54 import Network.Wai
  55 import Network.Wai.Handler.Warp hiding (defaultSettings)
  56 import Network.Wai.Middleware.Cors
  57 import Network.Wai.Middleware.RequestLogger
  58 import Paths_gargantext (getDataDir)
  59 import Servant
  60 import System.FilePath
  61
  62 data Mode = Dev | Mock | Prod
  63   deriving (Show, Read, Generic)
  64
  65 -- | startGargantext takes as parameters port number and Ini file.
  66 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
  67 startGargantext mode port file = do
  68   env <- newEnv port file
  69   portRouteInfo port
  70   app <- makeApp env
  71   mid <- makeDevMiddleware mode
  72   run port (mid app) `finally` stopGargantext env
  73
  74 portRouteInfo :: PortNumber -> IO ()
  75 portRouteInfo port = do
  76   putStrLn "      ----Main Routes-----      "
  77   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
  78   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
  79
  80 -- TODO clean this Monad condition (more generic) ?
  81 stopGargantext :: HasNodeStorySaver env => env -> IO ()
  82 stopGargantext env = do
  83   putStrLn "----- Stopping gargantext -----"
  84   runReaderT saveNodeStory env
  85
  86 {-
  87 startGargantextMock :: PortNumber -> IO ()
  88 startGargantextMock port = do
  89   portRouteInfo port
  90   application <- makeMockApp . MockEnv $ FireWall False
  91   run port application
  92 -}
  93
  94 ----------------------------------------------------------------------
  95
  96 fireWall :: Applicative f => Request -> FireWall -> f Bool
  97 fireWall req fw = do
  98     let origin = lookup "Origin" (requestHeaders req)
  99     let host   = lookup "Host"   (requestHeaders req)
 100
 101     if  origin == Just (encodeUtf8 "http://localhost:8008")
 102        && host == Just (encodeUtf8 "localhost:3000")
 103        || (not $ unFireWall fw)
 104
 105        then pure True
 106        else pure False
 107
 108 {-
 109 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 110 makeMockApp :: MockEnv -> IO Application
 111 makeMockApp env = do
 112     let serverApp = appMock
 113
 114     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 115     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 116     let checkOriginAndHost app req resp = do
 117             blocking <- fireWall req (env ^. menv_firewall)
 118             case blocking  of
 119                 True  -> app req resp
 120                 False -> resp ( responseLBS status401 []
 121                               "Invalid Origin or Host header")
 122
 123     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 124 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 125             { corsOrigins        = Nothing --  == /*
 126             , corsMethods        = [ methodGet   , methodPost   , methodPut
 127                                    , methodDelete, methodOptions, methodHead]
 128             , corsRequestHeaders = ["authorization", "content-type"]
 129             , corsExposedHeaders = Nothing
 130             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 131             , corsVaryOrigin     = False
 132             , corsRequireOrigin  = False
 133             , corsIgnoreFailures = False
 134             }
 135
 136     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 137     --          $ Warp.defaultSettings
 138
 139     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 140     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 141 -}
 142
 143
 144 makeDevMiddleware :: Mode -> IO Middleware
 145 makeDevMiddleware mode = do
 146 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 147 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 148 --    let checkOriginAndHost app req resp = do
 149 --            blocking <- fireWall req (env ^. menv_firewall)
 150 --            case blocking  of
 151 --                True  -> app req resp
 152 --                False -> resp ( responseLBS status401 []
 153 --                              "Invalid Origin or Host header")
 154 --
 155     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 156 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 157             { corsOrigins        = Nothing --  == /*
 158             , corsMethods        = [ methodGet   , methodPost   , methodPut
 159                                    , methodDelete, methodOptions, methodHead]
 160             , corsRequestHeaders = ["authorization", "content-type"]
 161             , corsExposedHeaders = Nothing
 162             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 163             , corsVaryOrigin     = False
 164             , corsRequireOrigin  = False
 165             , corsIgnoreFailures = False
 166             }
 167
 168     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 169     --          $ Warp.defaultSettings
 170
 171     --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
 172     case mode of
 173       Prod -> pure $ logStdout . corsMiddleware
 174       _    -> pure $ logStdoutDev . corsMiddleware
 175
 176 ---------------------------------------------------------------------
 177 -- | API Global
 178 ---------------------------------------------------------------------
 179
 180 ---------------------------
 181
 182
 183 -- TODO-SECURITY admin only: withAdmin
 184 -- Question: How do we mark admins?
 185 {-
 186 serverGargAdminAPI :: GargServer GargAdminAPI
 187 serverGargAdminAPI =  roots
 188                  :<|> nodesAPI
 189 -}
 190
 191 ---------------------------------------------------------------------
 192 --gargMock :: Server GargAPI
 193 --gargMock = mock apiGarg Proxy
 194 ---------------------------------------------------------------------
 195
 196 makeApp :: (Typeable env, EnvC env) => env -> IO Application
 197 makeApp env = do
 198   serv <- server env
 199   (ekgStore, ekgMid) <- newEkgStore api
 200   ekgDir <- (</> "ekg-assets") <$> getDataDir
 201   return $ ekgMid $ serveWithContext apiWithEkg cfg
 202     (ekgServer ekgDir ekgStore :<|> serv)
 203   where
 204     cfg :: Servant.Context AuthContext
 205     cfg = env ^. settings . jwtSettings
 206        :. env ^. settings . cookieSettings
 207     -- :. authCheck env
 208        :. EmptyContext
 209
 210 --appMock :: Application
 211 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 212 ---------------------------------------------------------------------
 213 api :: Proxy API
 214 api  = Proxy
 215
 216 apiWithEkg :: Proxy (EkgAPI :<|> API)
 217 apiWithEkg = Proxy
 218
 219 apiGarg :: Proxy GargAPI
 220 apiGarg  = Proxy
 221 ---------------------------------------------------------------------
 222
 223 {- UNUSED
 224 --import GHC.Generics (D1, Meta (..), Rep, Generic)
 225 --import GHC.TypeLits (AppendSymbol, Symbol)
 226 ---------------------------------------------------------------------
 227 -- Type Family for the Documentation
 228 type family TypeName (x :: *) :: Symbol where
 229     TypeName Int  = "Int"
 230     TypeName Text = "Text"
 231     TypeName x    = GenericTypeName x (Rep x ())
 232
 233 type family GenericTypeName t (r :: *) :: Symbol where
 234     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 235
 236 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 237 -}