content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ViewPatterns #-}
  {-# LANGUAGE LambdaCase #-}
  
  module Main (main) where
  
  import Control.Lens
  import Control.Lens.Extras (is)
  import Control.Monad
  import Data.Monoid (First)
  import DeckGo.Handler
  import Network.HTTP.Client (newManager, defaultManagerSettings)
  import Network.HTTP.Types as HTTP
  import Servant.API
  import Servant.Client
  import System.Environment
  import System.Environment (getEnv)
  import UnliftIO
  import qualified Data.Aeson as Aeson
  import qualified Data.ByteString.Char8 as BS8
  import qualified Data.HashMap.Strict as HMS
  import qualified Data.Text as T
  import qualified Data.Text.IO as T
  import qualified Hasql.Connection as HC
  import qualified Hasql.Session as HS
  import qualified Network.AWS.Extended as AWS
  import qualified Network.AWS.S3 as S3
  import qualified Network.AWS.SQS as SQS
  import qualified Network.HTTP.Client as HTTPClient
  import qualified Network.HTTP.Client.TLS as HTTPClient
  import qualified Network.Socket.Wait as Socket
  import qualified Network.Wai.Handler.Warp as Warp
  import qualified Servant.Auth.Firebase as Firebase
  import qualified Test.Tasty as Tasty
  import qualified Test.Tasty.HUnit as Tasty
  
  withEnv :: (AWS.Env -> IO a) -> IO a
  withEnv act = do
      mgr <- HTTPClient.newManager HTTPClient.tlsManagerSettings
              { HTTPClient.managerModifyRequest =
                  pure . rerouteSQS . rerouteS3
              }
      env <- AWS.newEnv <&> AWS.envManager .~ mgr
      act env
  
  withServer :: (Warp.Port -> IO a) -> IO a
  withServer act =
      withPresURL $ withEnv $ \env -> withS3 env $ withSQS env $
        withPristineDB $ \conn -> do
          putStrLn "Server environment loaded, finding port"
          (port, socket) <- Warp.openFreePort
          let warpSettings = Warp.setPort port $ Warp.defaultSettings
          settings <- getFirebaseSettings
          putStrLn "Starting server"
          race
            (Warp.runSettingsSocket warpSettings socket $
              DeckGo.Handler.application settings env conn)
            (do
              putStrLn "Waiting for server..."
              Socket.wait "0.0.0.0" port
              putStrLn "Server ready!"
              act port
            ) >>= \case
              Left () -> error "Server returned"
              Right a -> pure a
    where
      withPresURL =
        bracket_ (setEnv "DECKGO_PRESENTATIONS_URL" "foo.bar.baz") (unsetEnv "DECKGO_PRESENTATIONS_URL")
  
  is'
    :: AWS.AsError a
    => Getting (First AWS.ServiceError) a AWS.ServiceError
    -> a
    -> Bool
  is' prsm v = is _Just $ v ^? prsm
  
  withSQS :: AWS.Env -> IO a -> IO a
  withSQS env act = withQueueName $ do
      runAWS env (AWS.send $ SQS.getQueueURL ttestQueueName) >>= \case
        Right r -> runAWS env (AWS.send $
            SQS.deleteQueue ttestQueueName & SQS.dqQueueURL .~ (r ^. SQS.gqursQueueURL)
            ) >>= \case
          Left e -> error $ "Could not delete queue: " <> show e
          Right {} -> pure ()
        Left e
          | is' SQS._QueueDoesNotExist e -> pure ()
          | otherwise -> error $ "Could not get queue URL: " <> show e
  
      putStrLn $ "Creating " <> testQueueName
  
      runAWS env (AWS.send $ SQS.createQueue ttestQueueName) >>= \case
        Left e -> error $ "Could not create queue: " <> show e
        Right {} -> pure ()
      act
    where
      testQueueName = "the-queue"
      ttestQueueName = T.pack testQueueName
      withQueueName =
        bracket_ (setEnv "QUEUE_NAME" testQueueName) (unsetEnv "QUEUE_NAME")
  
  withS3 :: AWS.Env -> IO a -> IO a
  withS3 env act = do
      let bucket = S3.BucketName bucketName
      putStrLn "Emptying bucket, if exists"
      try (deleteObjects env bucket Nothing) >>= \case
        Right () -> pure ()
        Left (Err msg e)
          | is' S3._NoSuchBucket e -> pure ()
          | otherwise -> error $ T.unpack msg <> ": " <> show e
  
      putStrLn "Deleting bucket, if exists"
      runAWS env (AWS.send $ S3.deleteBucket bucket) >>= \case
        Right {} -> pure ()
        Left e
          | is' S3._NoSuchBucket e -> pure ()
          | otherwise -> error $ "Could not delete bucket: " <> show e
  
      putStrLn "Creating bucket"
  
      runAWS env (AWS.send $ S3.createBucket bucket) >>= \case
        Right {} -> pure ()
        Left e -> error $ "Could not create bucket: " <> show e
      withBucketName act
    where
      bucketName = "deckgo-bucket-foo"
      withBucketName =
        bracket_ (setEnv "BUCKET_NAME" (T.unpack bucketName)) (unsetEnv "BUCKET_NAME")
  
  withPristineDB :: (HC.Connection -> IO a) -> IO a
  withPristineDB act = do
      conn <- getPostgresqlConnection
      putStrLn "DROP TABLE IF EXISTS username"
      void $ HS.run (HS.sql "DROP TABLE IF EXISTS username") conn
      putStrLn "DROP TABLE IF EXISTS account CASCADE"
      void $ HS.run (HS.sql "DROP TABLE IF EXISTS account CASCADE") conn
      putStrLn "DROP TABLE IF EXISTS slide"
      void $ HS.run (HS.sql "DROP TABLE IF EXISTS slide") conn
      putStrLn "DROP TABLE IF EXISTS presentation"
      void $ HS.run (HS.sql "DROP TABLE IF EXISTS presentation") conn
      putStrLn "DROP TABLE IF EXISTS deck"
      void $ HS.run (HS.sql "DROP TABLE IF EXISTS deck") conn
      putStrLn "DROP TABLE IF EXISTS db_meta"
      void $ HS.run (HS.sql "DROP TABLE IF EXISTS db_meta") conn
      act conn
  
  main :: IO ()
  main = do
      setEnv "TASTY_NUM_THREADS" "1"
      Tasty.defaultMain $ Tasty.testGroup "tests"
        [ Tasty.testGroup "db"
            [ Tasty.testGroup "users"
                [ Tasty.testCase "get" testUsersGet
                , Tasty.testCase "create" testUsersCreate
                , Tasty.testCase "get by id" testUsersGetByUserId
                , Tasty.testCase "delete" testUsersDelete
                , Tasty.testCase "update" testUsersUpdate
                ]
            ]
        , Tasty.testCase "presentation" testPresDeploys
        , Tasty.testCase "server" testServer
        ]
  
  testPresDeploys :: IO ()
  testPresDeploys = withQueueName $ withEnv $ \env -> withSQS env $ withS3 env $ do
      let someFirebaseId = FirebaseId "the-uid" -- from ./token
      let someUserId = UserId someFirebaseId
  
      let someSlide = Slide (Just "foo") "bar" HMS.empty
  
      let somePres = PresentationInfo
            { presentationName = PresentationName "some-pres"
            , presentationSlides = [someSlide]
            , presentationOwner = someUserId
            , presentationAttributes = HMS.empty
            , presentationBackground = Nothing
            , presentationHeader = Nothing
            , presentationFooter = Nothing
            , presentationDescription = ""
            , presentationHeadExtra = Nothing
            }
  
      let uname = Username "josph"
      let psname = sanitizePresentationName (presentationName somePres)
  
      deployPresentation env uname psname somePres
      -- XXX: tests the obj diffing by making sure we can upload a presentation
      -- twice without errors
      deployPresentation env uname psname somePres
    where
      testQueueName = "the-queue"
      withQueueName =
        bracket_ (setEnv "QUEUE_NAME" testQueueName) (unsetEnv "QUEUE_NAME")
  
  testUsersGet :: IO ()
  testUsersGet = withPristineDB $ \conn -> do
      iface <- getDbInterface conn
      dbGetAllUsers iface >>= \case
        [] -> pure ()
        users -> error $ "Expected no users, got: " <> show users
  
      let someFirebaseId = FirebaseId "foo"
          someUserId = UserId someFirebaseId
          someUser = User
            { userFirebaseId = someFirebaseId
            , userUsername = Just (Username "patrick")
            }
      dbCreateUser iface someUserId someUser >>= \case
        Left () -> error "Encountered error"
        Right _ -> pure ()
  
      dbGetAllUsers iface >>= \case
        [Item userId user] ->
          if userId == someUserId && user == someUser
          then pure ()
          else error "bad user"
        users -> error $ "Expected no users, got: " <> show users
  
  testUsersGetByUserId :: IO ()
  testUsersGetByUserId = withPristineDB $ \conn -> do
      iface <- getDbInterface conn
      let someFirebaseId = FirebaseId "foo"
          someUserId = UserId someFirebaseId
          someUser = User
            { userFirebaseId = someFirebaseId
            , userUsername = Just (Username "patrick")
            }
      dbCreateUser iface someUserId someUser >>= \case
        Left () -> error "Encountered error"
        Right _ -> pure ()
  
      dbGetUserById iface someUserId >>= \case
        Just (Item userId user) ->
          if userId == someUserId && user == someUser
          then pure ()
          else error "bad user"
        Nothing -> error "Got no users"
  
  testUsersDelete :: IO ()
  testUsersDelete = withPristineDB $ \conn -> do
      iface <- getDbInterface conn
      let someFirebaseId = FirebaseId "foo"
          someUserId = UserId someFirebaseId
          someUser = User
            { userFirebaseId = someFirebaseId
            , userUsername = Just (Username "patrick")
            }
      dbCreateUser iface someUserId someUser >>= \case
        Left () -> error "Encountered error"
        Right _ -> pure ()
  
      dbDeleteUser iface someUserId >>= \case
        Left () -> error "couldn't delete"
        Right () -> pure ()
  
  testUsersCreate :: IO ()
  testUsersCreate = withPristineDB $ \conn -> do
      iface <- getDbInterface conn
      let someFirebaseId = FirebaseId "foo"
          someUserId = UserId someFirebaseId
          someUser = User
            { userFirebaseId = someFirebaseId
            , userUsername = Just (Username "patrick")
            }
      dbCreateUser iface someUserId someUser >>= \case
        Left () -> error "Encountered error"
        Right _ -> pure ()
  
  testUsersUpdate :: IO ()
  testUsersUpdate = withPristineDB $ \conn -> do
      iface <- getDbInterface conn
      let someFirebaseId = FirebaseId "foo"
          someUserId = UserId someFirebaseId
          someUser = User
            { userFirebaseId = someFirebaseId
            , userUsername = Just (Username "patrick")
            }
  
      dbCreateUser iface someUserId someUser >>= \case
        Left () -> error "Encountered error"
        Right _ -> pure ()
  
      let someUser' = User
            { userFirebaseId = someFirebaseId
            , userUsername = Just (Username "joseph")
            }
  
      dbUpdateUser iface someUserId someUser' >>= \case
        UserUpdateOk -> pure ()
        e -> error $ "encountered error:" <> show e
  
      dbGetUserById iface someUserId >>= \case
        Just (Item userId user) ->
          if userId == someUserId && user == someUser'
          then pure ()
          else error "bad user"
        Nothing -> error "Got no users"
  
  getTokenPath :: IO FilePath
  getTokenPath =
      lookupEnv "TEST_TOKEN_PATH" >>= \case
        Just tpath -> pure tpath
        Nothing -> pure "./token"
  
  testServer :: IO ()
  testServer = withServer $ \port -> do
    b <- T.readFile =<< getTokenPath
  
    manager' <- newManager defaultManagerSettings
  
    let clientEnv = mkClientEnv manager' (BaseUrl Http "localhost" port "")
    let someFirebaseId = FirebaseId "the-uid" -- from ./token
    let someUserId = UserId someFirebaseId
  
    runClientM usersGet' clientEnv >>= \case
      Left e -> error $ "Expected users, got error: " <> show e
      Right [] -> pure ()
      Right users -> error $ "Expected 0 users, got: " <> show users
  
    let someUserInfo = UserInfo
          { userInfoFirebaseId = someFirebaseId
          , userInfoEmail = Just "patrick@foo.com" }
        Right someUser = userInfoToUser someUserInfo
  
    runClientM (usersPost' b someUserInfo) clientEnv >>= \case
      Left e -> error $ "Expected user, got error: " <> show e
      Right (Item userId user) ->
        if user == someUser && userId == someUserId then pure () else (error $ "Expected same user, got: " <> show user)
  
    runClientM (usersPost' b someUserInfo) clientEnv >>= \case
      -- TODO: test that user is returned here, even on 409
      Left (FailureResponse _ resp) ->
        if HTTP.statusCode (responseStatusCode resp) == 409 then pure () else
          error $ "Got unexpected response: " <> show resp
      Left e -> error $ "Expected 409, got error: " <> show e
      Right item -> error $ "Expected failure, got success: " <> show item
  
  
    -- TODO: test that creating user with token that has different user as sub
    -- fails
  
  usersGet' :: ClientM [Item UserId User]
  _usersGetUserId' :: UserId -> ClientM (Item UserId User)
  usersPost' :: T.Text -> UserInfo -> ClientM (Item UserId User)
  _usersPut' :: T.Text -> UserId -> User -> ClientM (Item UserId User)
  _usersDelete' :: T.Text -> UserId -> ClientM ()
  
  _presentationsPost' :: T.Text -> PresentationInfo -> ClientM (Item PresentationId PresentationResult)
  _presentationsPut' :: T.Text -> PresentationId -> PresentationInfo -> ClientM (Item PresentationId PresentationResult)
  ((
    usersGet' :<|>
    _usersGetUserId' :<|>
    usersPost' :<|>
    _usersPut' :<|>
    _usersDelete'
    ) :<|>
    (
    _presentationsPost' :<|>
    _presentationsPut'
    )
    ) = client api
  
  rerouteSQS :: HTTPClient.Request -> HTTPClient.Request
  rerouteSQS req =
      case HTTPClient.host req of
        "sqs.us-east-1.amazonaws.com" ->
          req
            { HTTPClient.host = "127.0.0.1"
            , HTTPClient.port = 9324 -- TODO: read from Env
            , HTTPClient.secure = False
            }
        "queue.amazonaws.com" ->
          req
            { HTTPClient.host = "127.0.0.1"
            , HTTPClient.port = 9324 -- TODO: read from Env
            , HTTPClient.secure = False
            }
        _ -> req
  
  rerouteS3 :: HTTPClient.Request -> HTTPClient.Request
  rerouteS3 req =
      case HTTPClient.host req of
        "s3.us-east-1.amazonaws.com" ->
          req
            { HTTPClient.host = "127.0.0.1"
            , HTTPClient.port = 9000 -- TODO: read from Env
            , HTTPClient.secure = False
            }
        "s3.amazonaws.com" ->
          req
            { HTTPClient.host = "127.0.0.1"
            , HTTPClient.port = 9000 -- TODO: read from Env
            , HTTPClient.secure = False
            }
        _ -> req
  
  getFirebaseSettings :: IO Firebase.FirebaseLoginSettings
  getFirebaseSettings = do
      pkeys <- getEnv "GOOGLE_PUBLIC_KEYS"
      pid <- getEnv "FIREBASE_PROJECT_ID"
      keyMap <- Aeson.decodeFileStrict pkeys >>= \case
        Nothing -> error "Could not decode key file"
        Just keyMap -> pure keyMap
      pure Firebase.FirebaseLoginSettings
        { Firebase.firebaseLoginProjectId = Firebase.ProjectId (T.pack pid)
        , Firebase.firebaseLoginGetKeys = pure keyMap
        }
  
  getPostgresqlConnection :: IO HC.Connection
  getPostgresqlConnection = do
      user <- getEnv "PGUSER"
      password <- getEnv "PGPASSWORD"
      host <- getEnv "PGHOST"
      db <- getEnv "PGDATABASE"
      port <- getEnv "PGPORT"
      HC.acquire (
        HC.settings
          (BS8.pack host)
          (read port)
          (BS8.pack user)
          (BS8.pack password)
          (BS8.pack db)
        ) >>= \case
          Left e -> error (show e)
          Right c -> pure c
  