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 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  30
  31 {-# LANGUAGE ConstraintKinds      #-}
  32 {-# LANGUAGE TemplateHaskell      #-}
  33 {-# LANGUAGE TypeOperators        #-}
  34 {-# LANGUAGE KindSignatures       #-}
  35 {-# LANGUAGE ScopedTypeVariables  #-}
  36 {-# LANGUAGE TypeFamilies         #-}
  37 {-# LANGUAGE UndecidableInstances #-}
  38
  39 ---------------------------------------------------------------------
  40 module Gargantext.API
  41       where
  42 ---------------------------------------------------------------------
  43 import Control.Exception (finally)
  44 import Control.Lens
  45 import Control.Monad.Except (withExceptT)
  46 import Control.Monad.Reader (runReaderT)
  47 import Data.Aeson.Encode.Pretty (encodePretty)
  48 import Data.List (lookup)
  49 import Data.Swagger
  50 import Data.Text (Text)
  51 import Data.Text.Encoding (encodeUtf8)
  52 import Data.Validity
  53 import Data.Version (showVersion)
  54 import GHC.Base (Applicative)
  55 import GHC.Generics (D1, Meta (..), Rep, Generic)
  56 import GHC.TypeLits (AppendSymbol, Symbol)
  57 import Network.HTTP.Types hiding (Query)
  58 import Network.Wai
  59 import Network.Wai.Handler.Warp hiding (defaultSettings)
  60 import Network.Wai.Middleware.Cors
  61 import Network.Wai.Middleware.RequestLogger
  62 import Servant
  63 import Servant.Auth.Server (AuthResult(..))
  64 import Servant.Auth.Swagger ()
  65 import Servant.Swagger
  66 import Servant.Swagger.UI
  67 import System.IO (FilePath)
  68 import qualified Data.ByteString.Lazy.Char8 as BL8
  69 import qualified Data.Text.IO               as T
  70 import qualified Paths_gargantext           as PG -- cabal magic build module
  71
  72 import qualified Gargantext.API.Public      as Public
  73
  74 import Gargantext.Prelude.Config (gc_url)
  75 import Gargantext.API.Admin.Auth (AuthContext, auth)
  76 import Gargantext.API.Admin.FrontEnd (frontEndServer)
  77 import Gargantext.API.Admin.Settings (newEnv)
  78 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, env_gargConfig, jwtSettings, settings)
  79 import Gargantext.API.Ngrams (HasRepoSaver(..), saveRepo)
  80 import Gargantext.API.Prelude
  81 import Gargantext.API.Routes
  82 import Gargantext.Prelude
  83
  84
  85 data Mode = Dev | Mock | Prod
  86        deriving (Show, Read, Generic)
  87
  88 -- | startGargantext takes as parameters port number and Ini file.
  89 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
  90 startGargantext mode port file = do
  91   env <- newEnv port file
  92   portRouteInfo port
  93
  94   let baseUrl = env ^. env_gargConfig . gc_url
  95   app <- makeApp env baseUrl
  96
  97   mid <- makeDevMiddleware mode
  98   run port (mid app) `finally` stopGargantext env
  99
 100 portRouteInfo :: PortNumber -> IO ()
 101 portRouteInfo port = do
 102   T.putStrLn "      ----Main Routes-----      "
 103   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
 104   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 105
 106 -- TODO clean this Monad condition (more generic) ?
 107 stopGargantext :: HasRepoSaver env => env -> IO ()
 108 stopGargantext env = do
 109   T.putStrLn "----- Stopping gargantext -----"
 110   runReaderT saveRepo env
 111
 112 -- | Output generated @swagger.json@ file for the @'TodoAPI'@.
 113 swaggerWriteJSON :: IO ()
 114 swaggerWriteJSON = BL8.writeFile "swagger.json" (encodePretty swaggerDoc)
 115
 116 -- | Swagger Specifications
 117 swaggerDoc :: Swagger
 118 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
 119   & info.title       .~ "Gargantext"
 120   & info.version     .~ (cs $ showVersion PG.version)
 121   -- & info.base_url     ?~ (URL "http://gargantext.org/")
 122   & info.description ?~ "REST API specifications"
 123   -- & tags             .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]
 124   & applyTagsFor (subOperations (Proxy :: Proxy GargAPI)(Proxy :: Proxy GargAPI))
 125                  ["Gargantext" & description ?~ "Main operations"]
 126   & info.license     ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
 127     where
 128         urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
 129
 130 {-
 131 startGargantextMock :: PortNumber -> IO ()
 132 startGargantextMock port = do
 133   portRouteInfo port
 134   application <- makeMockApp . MockEnv $ FireWall False
 135   run port application
 136 -}
 137
 138 ----------------------------------------------------------------------
 139
 140 fireWall :: Applicative f => Request -> FireWall -> f Bool
 141 fireWall req fw = do
 142     let origin = lookup "Origin" (requestHeaders req)
 143     let host   = lookup "Host"   (requestHeaders req)
 144
 145     if  origin == Just (encodeUtf8 "http://localhost:8008")
 146        && host == Just (encodeUtf8 "localhost:3000")
 147        || (not $ unFireWall fw)
 148
 149        then pure True
 150        else pure False
 151
 152 {-
 153 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 154 makeMockApp :: MockEnv -> IO Application
 155 makeMockApp env = do
 156     let serverApp = appMock
 157
 158     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 159     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 160     let checkOriginAndHost app req resp = do
 161             blocking <- fireWall req (env ^. menv_firewall)
 162             case blocking  of
 163                 True  -> app req resp
 164                 False -> resp ( responseLBS status401 []
 165                               "Invalid Origin or Host header")
 166
 167     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 168 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 169             { corsOrigins        = Nothing --  == /*
 170             , corsMethods        = [ methodGet   , methodPost   , methodPut
 171                                    , methodDelete, methodOptions, methodHead]
 172             , corsRequestHeaders = ["authorization", "content-type"]
 173             , corsExposedHeaders = Nothing
 174             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 175             , corsVaryOrigin     = False
 176             , corsRequireOrigin  = False
 177             , corsIgnoreFailures = False
 178             }
 179
 180     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 181     --          $ Warp.defaultSettings
 182
 183     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 184     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 185 -}
 186
 187
 188 makeDevMiddleware :: Mode -> IO Middleware
 189 makeDevMiddleware mode = do
 190 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 191 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 192 --    let checkOriginAndHost app req resp = do
 193 --            blocking <- fireWall req (env ^. menv_firewall)
 194 --            case blocking  of
 195 --                True  -> app req resp
 196 --                False -> resp ( responseLBS status401 []
 197 --                              "Invalid Origin or Host header")
 198 --
 199     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 200 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 201             { corsOrigins        = Nothing --  == /*
 202             , corsMethods        = [ methodGet   , methodPost   , methodPut
 203                                    , methodDelete, methodOptions, methodHead]
 204             , corsRequestHeaders = ["authorization", "content-type"]
 205             , corsExposedHeaders = Nothing
 206             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 207             , corsVaryOrigin     = False
 208             , corsRequireOrigin  = False
 209             , corsIgnoreFailures = False
 210             }
 211
 212     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 213     --          $ Warp.defaultSettings
 214
 215     --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
 216     case mode of
 217       Prod -> pure $ logStdout . corsMiddleware
 218       _    -> pure $ logStdoutDev . corsMiddleware
 219
 220 ---------------------------------------------------------------------
 221 -- | API Global
 222 ---------------------------------------------------------------------
 223 -- | Server declarations
 224 server :: forall env. EnvC env => env -> Text -> IO (Server API)
 225 server env baseUrl = do
 226   -- orchestrator <- scrapyOrchestrator env
 227   pure $  schemaUiServer swaggerDoc
 228      :<|> hoistServerWithContext
 229             (Proxy :: Proxy GargAPI)
 230             (Proxy :: Proxy AuthContext)
 231             transform
 232             (serverGargAPI baseUrl)
 233      :<|> frontEndServer
 234   where
 235     transform :: forall a. GargServerM env GargError a -> Handler a
 236     transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
 237
 238
 239
 240 showAsServantErr :: GargError -> ServerError
 241 showAsServantErr (GargServerError err) = err
 242 showAsServantErr a = err500 { errBody = BL8.pack $ show a }
 243
 244 ---------------------------
 245
 246 serverGargAPI :: Text -> GargServerT env err (GargServerM env err) GargAPI
 247 serverGargAPI baseUrl -- orchestrator
 248        =  auth
 249      :<|> gargVersion
 250      :<|> serverPrivateGargAPI
 251      :<|> (Public.api baseUrl)
 252
 253   --   :<|> orchestrator
 254   where
 255     gargVersion :: GargServer GargVersion
 256     gargVersion = pure (cs $ showVersion PG.version)
 257
 258     serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
 259     serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
 260     serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
 261 -- Here throwAll' requires a concrete type for the monad.
 262
 263
 264 -- TODO-SECURITY admin only: withAdmin
 265 -- Question: How do we mark admins?
 266 {-
 267 serverGargAdminAPI :: GargServer GargAdminAPI
 268 serverGargAdminAPI =  roots
 269                  :<|> nodesAPI
 270 -}
 271
 272 ---------------------------------------------------------------------
 273 --gargMock :: Server GargAPI
 274 --gargMock = mock apiGarg Proxy
 275 ---------------------------------------------------------------------
 276 makeApp :: EnvC env => env -> Text -> IO Application
 277 makeApp env baseUrl = serveWithContext api cfg <$> server env baseUrl
 278   where
 279     cfg :: Servant.Context AuthContext
 280     cfg = env ^. settings . jwtSettings
 281        :. env ^. settings . cookieSettings
 282     -- :. authCheck env
 283        :. EmptyContext
 284
 285 --appMock :: Application
 286 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 287 ---------------------------------------------------------------------
 288 api :: Proxy API
 289 api  = Proxy
 290
 291 apiGarg :: Proxy GargAPI
 292 apiGarg  = Proxy
 293 ---------------------------------------------------------------------
 294 schemaUiServer :: (Server api ~ Handler Swagger)
 295         => Swagger -> Server (SwaggerSchemaUI' dir api)
 296 schemaUiServer = swaggerSchemaUIServer
 297
 298 ---------------------------------------------------------------------
 299 -- Type Family for the Documentation
 300 type family TypeName (x :: *) :: Symbol where
 301     TypeName Int  = "Int"
 302     TypeName Text = "Text"
 303     TypeName x    = GenericTypeName x (Rep x ())
 304
 305 type family GenericTypeName t (r :: *) :: Symbol where
 306     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 307
 308 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 309
 310