SessionSpec.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : HStratus.SessionSpec
Copyright   : (c) 2023 Tim Emiola
Maintainer  : Tim Emiola <adetokunbo@emio.la>
SPDX-License-Identifier: BSD3
-}
module HStratus.SessionSpec (spec) where

import Control.Monad (when)
import Data.Aeson (decode, eitherDecodeFileStrict, encode, encodeFile, object, (.=))
import Data.Aeson.Types (parseJSON, parseMaybe)
import Data.Bits ((.&.))
import Data.Either (isLeft)
import Data.List (isInfixOf, sort)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.String (IsString (..))
import Data.Text (Text)
import qualified Data.Text.IO as Text
import Data.Word (Word16)
import HStratus.TrustSpec (jsonKeysOf)
import Network.HStratus.Internal.Session
  ( SavedHeaders (..)
  , accountDataPath
  , accountDataRequires2FA
  , accountDataRequires2SA
  , appBase
  , checkSecureMode
  , clientIdPath
  , cookiePath
  , credentialsPath
  , encodeFileAtomic
  , loadAccountData
  , loadSavedHeaders
  , requireSecureFile
  , saveAccountData
  , saveCredentialsTo
  , savedHeadersPath
  , unknownAccountData
  , updateSessionSavedHeaders
  , (</>)
  )
import Network.HStratus.Session (AccountData (..), Credentials (..), Session (..), Webservice (..), loadSession)
import System.Directory (createDirectory, doesFileExist)
import System.Environment (setEnv)
import System.IO.Error (ioeGetErrorString)
import System.IO.Temp (withSystemTempDirectory)
import System.Posix.Files (fileMode, getFileStatus, setFileMode)
import Test.Hspec
  ( Spec
  , anyIOException
  , around
  , context
  , describe
  , it
  , shouldBe
  , shouldReturn
  , shouldSatisfy
  , shouldThrow
  )
import Test.QuickCheck
  ( Arbitrary (arbitrary)
  , Gen
  , Property
  , elements
  , frequency
  , listOf
  )
import Test.QuickCheck.Monadic (assert, monadicIO, pick, run)


spec :: Spec
spec = do
  secureFileSpec
  secureWriteSpec
  checkSessionFilesSpec
  sessionSpec
  saveCredentialsSpec
  accountDataSpec


secureFileSpec :: Spec
secureFileSpec = describe "module Network.HStratus.Internal.Session (file security)" $ do
  describe "checkSecureMode" $ do
    it "accepts mode 0o600" $
      checkSecureMode 0o600 "/tmp/test" `shouldBe` Right ()
    it "accepts mode 0o400 (read-only owner)" $
      checkSecureMode 0o400 "/tmp/test" `shouldBe` Right ()
    it "accepts mode 0o700 (owner-execute)" $
      checkSecureMode 0o700 "/tmp/test" `shouldBe` Right ()
    it "rejects mode 0o644 (world-readable)" $
      checkSecureMode 0o644 "/tmp/test" `shouldSatisfy` isLeft
    it "rejects mode 0o640 (group-readable)" $
      checkSecureMode 0o640 "/tmp/test" `shouldSatisfy` isLeft
    it "rejects mode 0o604 (world-readable, no group)" $
      checkSecureMode 0o604 "/tmp/test" `shouldSatisfy` isLeft
    it "includes the path in the error message" $
      case checkSecureMode 0o644 "/some/path" of
        Left msg -> "/some/path" `isInfixOf` msg `shouldBe` True
        Right () -> fail "expected Left"
    it "includes chmod hint in the error message" $
      case checkSecureMode 0o644 "/some/path" of
        Left msg -> "chmod 600" `isInfixOf` msg `shouldBe` True
        Right () -> fail "expected Left"
  describe "requireSecureFile" $ around withTmpDir $ do
    it "does nothing when the file is absent" $ \tmpDir -> do
      requireSecureFile (tmpDir </> "absent.txt")
    it "does nothing when the file has mode 0o600" $ \tmpDir -> do
      let path = tmpDir </> "secure.txt"
      writeFile path "content"
      setFileMode path 0o600
      requireSecureFile path
    it "throws when the file has mode 0o644" $ \tmpDir -> do
      let path = tmpDir </> "insecure.txt"
      writeFile path "content"
      setFileMode path 0o644
      requireSecureFile path `shouldThrow` anyIOException
    it "includes the path in the error for a bad-permission file" $ \tmpDir -> do
      let path = tmpDir </> "insecure.txt"
      writeFile path "content"
      setFileMode path 0o644
      requireSecureFile path
        `shouldThrow` (\e -> tmpDir `isInfixOf` ioeGetErrorString e)


shouldHaveMode600 :: FilePath -> IO ()
shouldHaveMode600 path = do
  mode <- fileMode <$> getFileStatus path
  (mode .&. 0o777) `shouldBe` 0o600


secureWriteSpec :: Spec
secureWriteSpec = describe "module Network.HStratus.Internal.Session (secure writes)" $ do
  context "saveCredentialsTo" $ around withTmpDir $ do
    it "writes credentials.json with mode 0o600" $ \tmpDir -> do
      saveCredentialsTo tmpDir exampleCred
      shouldHaveMode600 (credentialsPath tmpDir)
  context "updateSessionSavedHeaders" $ around useTmp $ do
    it "writes session headers with mode 0o600" $ \appRoot -> do
      saveCredentialsTo appRoot exampleCred
      s <- loadSession
      updateSessionSavedHeaders s id
      shouldHaveMode600 (savedHeadersPath appRoot (sessionCreds s))
  context "saveAccountData" $ around useTmp $ do
    it "writes account-data with mode 0o600" $ \appRoot -> do
      saveCredentialsTo appRoot exampleCred
      s <- loadSession
      saveAccountData s unknownAccountData
      shouldHaveMode600 (accountDataPath appRoot (sessionCreds s))
  context "loadClientId (new file)" $ around useTmp $ do
    it "creates client-id file with mode 0o600" $ \appRoot -> do
      saveCredentialsTo appRoot exampleCred
      s <- loadSession
      shouldHaveMode600 (clientIdPath appRoot (sessionCreds s))


checkSessionFilesSpec :: Spec
checkSessionFilesSpec = describe "checkSessionFiles / loadSession" $ around useTmp $ do
  it "succeeds when credentials.json has mode 0o600" $ \appRoot -> do
    saveCredentialsTo appRoot exampleCred
    _ <- loadSession
    pure ()
  it "fails when credentials.json has mode 0o644" $ \appRoot -> do
    saveCredentialsTo appRoot exampleCred
    setFileMode (credentialsPath appRoot) 0o644
    loadSession `shouldThrow` anyIOException
  it "fails when session headers file has mode 0o644" $ \appRoot -> do
    saveCredentialsTo appRoot exampleCred
    s <- loadSession
    updateSessionSavedHeaders s id
    setFileMode (savedHeadersPath appRoot (sessionCreds s)) 0o644
    loadSession `shouldThrow` anyIOException


-- save credential somewhere
-- confirm Session loads

-- save credentials
-- save a pre-existing clientId
-- loadSession; confirm loaded session as the clientId

-- save credentials
-- save generated SavedHeaders
-- loadSession; confirm saveHeaders are loaded

sessionSpec :: Spec
sessionSpec = describe "module Network.HStratus.Session" $ do
  context "Using an example Credential" $ do
    let topDir = "/tmp/icloud_authspec"
    context "cookiePath" $ do
      it "should be computed correctly" $ do
        let want = "/tmp/icloud_authspec/myaccountid-applecom.cookies.txt"
        cookiePath topDir exampleCred `shouldBe` want

    context "savedHeadersPath" $ do
      it "should be computed correctly" $ do
        let want = "/tmp/icloud_authspec/myaccountid-applecom.session.json"
        savedHeadersPath topDir exampleCred `shouldBe` want

    context "clientIdPath" $ do
      it "should be computed correctly" $ do
        let want = "/tmp/icloud_authspec/myaccountid-applecom.client-id.txt"
        clientIdPath topDir exampleCred `shouldBe` want
  savedHeadersFieldNamesSpec
  loadSessionSpec
  loadSavedHeadersSpec
  updateSessionSavedHeadersSpec
  encodeFileAtomicSpec


savedHeadersFieldNamesSpec :: Spec
savedHeadersFieldNamesSpec = describe "SavedHeaders JSON field names" $ do
  it "uses the expected field names" $
    jsonKeysOf (SavedHeaders (Just "a") (Just "b") (Just "c") (Just "d") (Just "e"))
      `shouldBe` Just (sort ["country", "session_id", "session_token", "trust_token", "counter"])


loadSessionSpec :: Spec
loadSessionSpec = describe "loadSession" $ around useTmp $ do
  context "with an invalid credentials file" $ do
    it "should fail to load" $ \appRoot ->
      failsOnBadCredentials appRoot `shouldThrow` anyIOException
  context "with only the credentials file" $ do
    it "should load a Session with a new clientId" prop_loadsSession
  context "with a clientId file available" $ do
    it "should load the saved clientId" prop_readsStoredCliendId
  context "with a saved headers file" $ do
    it "should load the saved headers" prop_readsStoredSavedHeaders


loadSavedHeadersSpec :: Spec
loadSavedHeadersSpec = describe "loadSavedHeaders" $ around useTmp $ do
  context "with an invalid saved headers file" $ do
    it "should fail to load" $ \appRoot ->
      failsOnBadSavedHeaders appRoot `shouldThrow` anyIOException
    it "includes a re-login hint in the error message" $ \appRoot ->
      failsOnBadSavedHeaders appRoot
        `shouldThrow` (\e -> "hstratus auth login" `isInfixOf` ioeGetErrorString e)


updateSessionSavedHeadersSpec :: Spec
updateSessionSavedHeadersSpec = describe "updateSessionSavedHeaders" $ around useTmp $ do
  context "when some SaveHeaders are already saved" $ do
    it "should update to the new headers" $ prop_updatesSavedHeaders True
  context "when No SaveHeaders have been saved" $ do
    it "should update to the new headers" $ prop_updatesSavedHeaders True


useTmp :: (FilePath -> IO a) -> IO a
useTmp = withSystemTempDirectory "icloud-auth" . asConfigHome


setupInvalid :: FilePath -> IO ()
setupInvalid path = Text.writeFile path "[}"


failsOnBadCredentials :: FilePath -> IO Session
failsOnBadCredentials appRoot = do
  let path = credentialsPath appRoot
  setupInvalid path
  setFileMode path 0o600
  loadSession


failsOnBadSavedHeaders :: FilePath -> IO SavedHeaders
failsOnBadSavedHeaders appRoot = do
  saveCredentialsTo appRoot exampleCred
  let shPath = savedHeadersPath appRoot exampleCred
  setupInvalid shPath
  setFileMode shPath 0o600
  s <- loadSession
  loadSavedHeaders s


asConfigHome :: (FilePath -> IO a) -> FilePath -> IO a
asConfigHome action root = do
  setEnv "XDG_CONFIG_HOME" root
  let appRoot = root </> appBase
  createDirectory appRoot
  action appRoot


prop_loadsSession :: FilePath -> Property
prop_loadsSession appRoot = monadicIO $ do
  preCreds <- pick genPreCredentials
  let creds = asCreds preCreds
  s <- run $ do
    saveCredentialsTo appRoot creds
    loadSession
  assert $ sessionClientId s /= "" && creds == sessionCreds s


prop_readsStoredCliendId :: FilePath -> Property
prop_readsStoredCliendId appRoot = monadicIO $ do
  preCreds <- pick genPreCredentials
  fakeId <- pick $ genIndexedSuffix "client-id-"
  let creds = asCreds preCreds
  session <- run $ do
    saveCredentialsTo appRoot creds
    let cidPath = clientIdPath appRoot creds
    Text.writeFile cidPath fakeId
    setFileMode cidPath 0o600
    loadSession
  assert $ fakeId == sessionClientId session


prop_readsStoredSavedHeaders :: FilePath -> Property
prop_readsStoredSavedHeaders appRoot = monadicIO $ do
  preCreds <- pick genPreCredentials
  savedHdrs <- pick genSaveHeaders
  let creds = asCreds preCreds
  savedHdrs' <- run $ do
    saveCredentialsTo appRoot creds
    s <- loadSession
    updateSessionSavedHeaders s (const savedHdrs)
    loadSavedHeaders s
  assert $ savedHdrs == savedHdrs'


prop_updatesSavedHeaders :: Bool -> FilePath -> Property
prop_updatesSavedHeaders storeInitial appRoot = monadicIO $ do
  preCreds <- pick genPreCredentials
  savedHdrs <- pick genSaveHeaders
  newHdrs <- pick genSaveHeaders
  let creds = asCreds preCreds
  loadedHdrs <- run $ do
    saveCredentialsTo appRoot creds
    when storeInitial $ do
      let shPath = savedHeadersPath appRoot creds
      encodeFile shPath savedHdrs
      setFileMode shPath 0o600
    s <- loadSession
    updateSessionSavedHeaders s (const newHdrs)
    loadSavedHeaders s
  assert $ newHdrs == loadedHdrs


saveCredentialsSpec :: Spec
saveCredentialsSpec = describe "saveCredentialsTo" $ do
  context "in a pre-existing directory" $ around withTmpDir $ do
    it "creates the credentials file" $ \tmpDir -> do
      saveCredentialsTo tmpDir exampleCred
      doesFileExist (credentialsPath tmpDir) `shouldReturn` True
    it "round-trips credentials through JSON" prop_saveLoadCredentials
    it "overwrites when called a second time" prop_overwritesCredentials
  context "when the target directory does not exist" $ do
    it "creates the directory and the file" $
      withSystemTempDirectory "icloud-auth-creds" $ \tmp -> do
        let target = tmp </> "new-subdir"
        saveCredentialsTo target exampleCred
        doesFileExist (credentialsPath target) `shouldReturn` True


withTmpDir :: (FilePath -> IO a) -> IO a
withTmpDir = withSystemTempDirectory "icloud-auth-creds"


prop_saveLoadCredentials :: FilePath -> Property
prop_saveLoadCredentials tmpDir = monadicIO $ do
  creds <- asCreds <$> pick genPreCredentials
  result <- run $ do
    saveCredentialsTo tmpDir creds
    eitherDecodeFileStrict (credentialsPath tmpDir)
  assert $ result == Right creds


prop_overwritesCredentials :: FilePath -> Property
prop_overwritesCredentials tmpDir = monadicIO $ do
  creds1 <- asCreds <$> pick genPreCredentials
  creds2 <- asCreds <$> pick genPreCredentials
  result <- run $ do
    saveCredentialsTo tmpDir creds1
    saveCredentialsTo tmpDir creds2
    eitherDecodeFileStrict (credentialsPath tmpDir)
  assert $ result == Right creds2


exampleCred :: Credentials
exampleCred =
  Credentials
    { credAccountName = "my-account-id@apple.com"
    , credPassword = "notasecret"
    }


type PreCredentials = (Text, Text)


asCreds :: PreCredentials -> Credentials
asCreds (credAccountName, credPassword) = Credentials{credAccountName, credPassword}


genPreCredentials :: Gen PreCredentials
genPreCredentials =
  let mkId x = "account-" <> x <> "@apple.com"
   in (,) <$> genIndexedTemplate mkId <*> genIndexedSuffix "password-"


genSaveHeaders :: Gen SavedHeaders
genSaveHeaders =
  let arb pre = frequency [(2, pure Nothing), (1, Just <$> genIndexedSuffix pre)]
   in SavedHeaders
        <$> arb "country-"
        <*> arb "session-id-"
        <*> arb "session-token-"
        <*> arb "trust-token-"
        <*> arb "counter="


genWord16 :: Gen Word16
genWord16 = arbitrary


genIndexedSuffix :: (Monoid a, IsString a) => a -> Gen a
genIndexedSuffix pre = genIndexedTemplate (pre <>)


genIndexedTemplate :: (IsString a) => (a -> a) -> Gen a
genIndexedTemplate plate = plate . fromString . show <$> genWord16


accountDataSpec :: Spec
accountDataSpec = describe "module Network.HStratus.Session (AccountData)" $ do
  context "AccountData" $ do
    it "round-trips through JSON encoding" prop_jsonRoundtripAccountData
  context "accountDataRequires2FA" $ do
    it "is True when hsaVersion == 2 and challenged" $
      accountDataRequires2FA (mkAccountData 2 True (Just False)) `shouldBe` True
    it "is True when hsaVersion == 2, not challenged, but browser explicitly untrusted" $
      accountDataRequires2FA (mkAccountData 2 False (Just False)) `shouldBe` True
    it "is False when hsaVersion == 2, not challenged, and browser trusted" $
      accountDataRequires2FA (mkAccountData 2 False (Just True)) `shouldBe` False
    it "is False when hsaVersion == 2, not challenged, and hsaTrustedBrowser absent" $
      accountDataRequires2FA (mkAccountData 2 False Nothing) `shouldBe` False
    it "is False when hsaVersion is 1" $
      accountDataRequires2FA (mkAccountData 1 True (Just False)) `shouldBe` False
    it "is False when hsaVersion is 3 (unknown version)" $
      accountDataRequires2FA (mkAccountData 3 True (Just False)) `shouldBe` False
  context "accountDataRequires2SA" $ do
    it "is True when hsaVersion is 1" $
      accountDataRequires2SA (mkAccountData 1 False (Just False)) `shouldBe` True
    it "is False when hsaVersion is 2" $
      accountDataRequires2SA (mkAccountData 2 False (Just False)) `shouldBe` False
    it "is False when hsaVersion is 0" $
      accountDataRequires2SA (mkAccountData 0 False (Just False)) `shouldBe` False
  context "AccountData JSON parsing" $ do
    it "fails to parse from null JSON" $
      (decode "null" :: Maybe AccountData) `shouldBe` Nothing
    it "fails to parse when dsInfo is absent" $
      (decode "{}" :: Maybe AccountData) `shouldBe` Nothing
  context "saveAccountData / loadAccountData" $ around useTmp $ do
    it "round-trips in a temp directory" prop_saveLoadAccountData


prop_jsonRoundtripAccountData :: Property
prop_jsonRoundtripAccountData = monadicIO $ do
  ad <- pick genAccountData
  assert $ decode (encode ad) == Just ad


prop_saveLoadAccountData :: FilePath -> Property
prop_saveLoadAccountData appRoot = monadicIO $ do
  preCreds <- pick genPreCredentials
  ad <- pick genAccountData
  let creds = asCreds preCreds
  loaded <- run $ do
    saveCredentialsTo appRoot creds
    s <- loadSession
    saveAccountData s ad
    loadAccountData s
  assert $ Just ad == loaded


mkAccountData :: Int -> Bool -> Maybe Bool -> AccountData
mkAccountData ver challenged trusted =
  AccountData
    { adHsaVersion = ver
    , adHsaChallengeRequired = challenged
    , adHsaTrustedBrowser = trusted
    , adWebservices = Map.empty
    , adRaw = object []
    }


genAccountData :: Gen AccountData
genAccountData = do
  adHsaVersion <- abs <$> (arbitrary :: Gen Int)
  adHsaChallengeRequired <- (arbitrary :: Gen Bool)
  adHsaTrustedBrowser <- elements [Nothing, Just True, Just False]
  adWebservices <- Map.fromList <$> listOf genWsPair
  let trustedField = maybe [] (\t -> ["hsaTrustedBrowser" .= t]) adHsaTrustedBrowser
      v =
        object $
          [ "dsInfo" .= object ["hsaVersion" .= adHsaVersion]
          , "hsaChallengeRequired" .= adHsaChallengeRequired
          , "webservices"
              .= fmap
                (\(Webservice url st) -> object $ ["url" .= url] <> maybe [] (\s -> ["status" .= s]) st)
                adWebservices
          ]
            <> trustedField
  pure $ fromMaybe unknownAccountData (parseMaybe parseJSON v)
 where
  genWsPair :: Gen (Text, Webservice)
  genWsPair = (,) <$> elements wsNames <*> genWebservice
  genWebservice :: Gen Webservice
  genWebservice = Webservice <$> genIndexedSuffix "https://example.com/" <*> elements [Nothing, Just "active", Just "inactive"]
  wsNames = ["findme", "contacts", "calendar", "mail"]


encodeFileAtomicSpec :: Spec
encodeFileAtomicSpec = describe "encodeFileAtomic" $ around useTmp $ do
  it "round-trips a JSON value" $ \appRoot -> do
    let path = appRoot </> "test.json"
        value = object ["key" .= ("value" :: Text)]
    encodeFileAtomic path value
    result <- eitherDecodeFileStrict path
    result `shouldBe` Right value
  it "overwrites an existing file" $ \appRoot -> do
    let path = appRoot </> "test.json"
        old = object ["version" .= (1 :: Int)]
        new = object ["version" .= (2 :: Int)]
    encodeFileAtomic path old
    encodeFileAtomic path new
    result <- eitherDecodeFileStrict path
    result `shouldBe` Right new