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