diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,9 @@ +# Revision history for icloud-drive + +`icloud-drive` uses [PVP Versioning][1]. + +## 0.1.0.0 -- 2026-07-28 + +* Initial version. + +[1]: https://pvp.haskell.org diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Tim Emiola + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tim Emiola nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,72 @@ +# hstratus-drive — access to iCloud Drive + +`hstratus-drive` browses and downloads files from iCloud Drive using an +authenticated session from [`hstratus-auth`](https://github.com/adetokunbo/hstratus/tree/main/hstratus-auth/). + +Provides access to the main CloudDocs tree: fetching the root folder, +listing folder contents, downloading files, and mutating the tree (create, +rename, delete, upload). + + +## Disclaimer — use at your own risk + +- This library is **unofficial** and not supported by Apple. +- The iCloud Drive API it uses is undocumented and may change without notice. + + +## Usage + +After a successful login with `hstratus-auth`, construct a `DriveApi` value and +use it to browse or download files. + +### Browsing + +```haskell +import Network.HStratus.Http (mkApi, login, AuthState (..)) +import Network.HStratus.Http.Endpoints (Realm (..)) +import Network.HStratus.Drive + +example :: IO () +example = do + api <- mkApi Usual + result <- login api + case result of + Authenticated sess ad -> do + da <- mkDriveApi ad sess api + root <- driveRoot da + nodes <- listFolder da (fnId root) + mapM_ print nodes + _ -> putStrLn "Unexpected result" +``` + +### Downloading + +```haskell +downloadExample :: DriveApi -> FileData -> IO () +downloadExample da fd = do + bytes <- downloadFile da fd + -- bytes :: Data.ByteString.Lazy.ByteString + print (Data.ByteString.Lazy.length bytes) +``` + +### Mutating + +```haskell +mutationExample :: DriveApi -> FolderData -> IO () +mutationExample da folder = do + createFolder da (fnId folder) "New Folder" + -- renameNode, deleteNode, and uploadFile follow the same pattern +``` + + +## CLI usage + +A command-line interface using this behaviour is provided by the [`hstratus`](https://github.com/adetokunbo/hstratus/tree/main/hstratus/#readme) +package. Use [`hstratus drive ls`](https://github.com/adetokunbo/hstratus/tree/main/hstratus/#hstratus-drive-ls) to list Drive contents and +[`hstratus drive cp`](https://github.com/adetokunbo/hstratus/tree/main/hstratus/#hstratus-drive-cp) to download files. + + +--- + +Apple and the Apple logo are trademarks of Apple Inc., registered in the U.S. and other countries and regions. +iCloud is a service mark of Apple Inc., registered in the U.S. and other countries and regions. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + + +main = defaultMain diff --git a/hstratus-drive.cabal b/hstratus-drive.cabal new file mode 100644 --- /dev/null +++ b/hstratus-drive.cabal @@ -0,0 +1,103 @@ +cabal-version: 3.0 +name: hstratus-drive +version: 0.1.0.0 +synopsis: Access iCloud Drive +description: + Browse and download files from iCloud Drive using an authenticated session + from the @hstratus-auth@ library. + + Provides access to the main CloudDocs tree: fetching the root folder, + listing folder contents, downloading files, and mutating the tree (create, + rename, delete, upload). + + This library is unofficial and not supported by Apple. It may break + without warning if Apple changes their API. + +license: BSD-3-Clause +license-file: LICENSE +author: Tim Emiola +maintainer: Tim Emiola +copyright: (c) 2026 Tim Emiola +category: Network +build-type: Simple +tested-with: + GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.2 + , GHC == 9.12.1 +extra-doc-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/adetokunbo/hstratus.git + subdir: hstratus-drive + +library + exposed-modules: + Network.HStratus.Drive + Network.HStratus.Drive.Node + hs-source-dirs: src + build-depends: + , base >=4.12 && <5 + , bytestring >=0.10.8 && <0.11 || >=0.11.3 && <0.13 + , hstratus-auth >=0.1 && <0.2 + , hstratus-drive:hstratus-drive-internal + , text >=1.2.3 && <2.2 + , time >=1.8 && <1.15 + default-language: Haskell2010 + ghc-options: -Wall -Wincomplete-uni-patterns -Wpartial-fields -fwarn-tabs + +library hstratus-drive-internal + exposed-modules: + Network.HStratus.Internal.Drive.Download + Network.HStratus.Internal.Drive.Endpoints + Network.HStratus.Internal.Drive.Node + Network.HStratus.Internal.Drive.NodeData + hs-source-dirs: src-internal + build-depends: + , aeson >=2.0 && <2.3 + , base >=4.12 && <5 + , bytestring >=0.10.8 && <0.11 || >=0.11.3 && <0.13 + , case-insensitive >=1.2 && <1.3 + , containers >=0.6 && <0.8 + , http-client >=0.5 && <0.8 + , http-types >=0.12.1 && <0.13 + , hstratus-auth >=0.1 && <0.2 + , text >=1.2.3 && <2.2 + , time >=1.9 && <1.15 + , vector >=0.12 && <0.14 + default-language: Haskell2010 + ghc-options: -Wall -Wincomplete-uni-patterns -Wpartial-fields -fwarn-tabs + +test-suite test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + HStratus.Drive.EndpointsSpec + HStratus.Drive.MutationSpec + HStratus.Drive.NodeSpec + HStratus.Drive.UploadSpec + HStratus.DriveSpec + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs + build-depends: + , aeson >=2.0 && <2.3 + , base + , bytestring >=0.10.8 && <0.11 || >=0.11.3 && <0.13 + , containers >=0.6 && <0.8 + , hspec >=2.1 && <3.0 + , http-client >=0.5 && <0.8 + , http-types >=0.12.1 && <0.13 + , hstratus-auth >=0.1 && <0.2 + , hstratus-drive + , hstratus-drive:hstratus-drive-internal + , temporary >=1.2 && <1.4 + , text >=1.2.3 && <2.2 + , time >=1.9 && <1.15 + , wai >=3.2 && <3.3 + , warp >=3.2 && <3.5 diff --git a/src-internal/Network/HStratus/Internal/Drive/Download.hs b/src-internal/Network/HStratus/Internal/Drive/Download.hs new file mode 100644 --- /dev/null +++ b/src-internal/Network/HStratus/Internal/Drive/Download.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK prune #-} + +{- | +Module : Network.HStratus.Internal.Drive.Download +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD-3-Clause + +API-call functions for reading and writing iCloud Drive nodes. +-} +module Network.HStratus.Internal.Drive.Download + ( DriveError (..) + , fetchNode + , fetchChildren + , fetchFile + , execCreateFolder + , execRenameNode + , execDeleteNode + , execUploadFile + ) +where + +import Control.Exception (Exception, throwIO) +import Control.Monad (when) +import Data.Aeson (Value, eitherDecode, encode, object, (.=)) +import Data.Aeson.Types (Parser, parseEither) +import qualified Data.ByteString.Lazy as LBS +import Data.Int (Int64) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time.Clock.POSIX (getPOSIXTime) +import Network.HStratus.Http (Api, HStratusError, rawRequest) +import Network.HStratus.Internal.Drive.Endpoints + ( DriveEndpoints + , commitUploadReq + , createFolderBody + , createFolderReq + , deleteNodeBody + , deleteNodeReq + , downloadTokenReq + , nodeDetailsBody + , nodeDetailsReq + , renameNodeBody + , renameNodeReq + , uploadTokenReq + ) +import Network.HStratus.Internal.Drive.Node + ( DriveNode (..) + , DriveNodeId (..) + , FileData (..) + , FolderData (..) + , folderDocId + , nodeEtag + , nodeId + ) +import Network.HStratus.Internal.Drive.NodeData + ( UploadReceipt (..) + , parseChildrenResponse + , parseDownloadUrl + , parseNodeResponse + , parseUploadReceiptResponse + , parseUploadTokenResponse + ) +import Network.HTTP.Client + ( Request + , RequestBody (..) + , Response (..) + , parseRequest + , requestBody + , requestHeaders + ) +import Network.HTTP.Client.MultipartFormData (formDataBody, partContentType, partFilename, partLBS) +import Network.HTTP.Types (hContentType, statusCode) + + +-- | Errors that can occur during iCloud Drive API calls. +data DriveError + = -- | the server returned an unexpected HTTP status code + DriveHttpError Int + | -- | a JSON response could not be decoded into the expected structure + DriveParseError String + | -- | the drive root node could not be resolved + DriveInvalidRoot + + +instance Show DriveError where + show (DriveHttpError n) = "iCloud Drive: HTTP error " <> show n + show (DriveParseError msg) = "iCloud Drive: parse error: " <> msg + show DriveInvalidRoot = "iCloud Drive: invalid root node" + + +instance Exception DriveError + + +instance HStratusError DriveError + + +-- | Fetch metadata for a single node. +fetchNode :: Api -> DriveEndpoints -> DriveNodeId -> IO DriveNode +fetchNode api ep nid = fetchWith "fetchNode" api (nodeReq ep nid) parseNodeResponse + + +-- | Fetch the immediate children of a folder. +fetchChildren :: Api -> DriveEndpoints -> DriveNodeId -> IO [DriveNode] +fetchChildren api ep nid = fetchWith "fetchChildren" api (nodeReq ep nid) parseChildrenResponse + + +-- | Download the contents of a file node as a lazy 'LBS.ByteString'. +fetchFile :: Api -> DriveEndpoints -> FileData -> IO LBS.ByteString +fetchFile api ep fd + | maybe True (== 0) (fdSize fd) = pure LBS.empty + | otherwise = do + url <- fetchWith "fetchFile (token)" api (downloadTokenReq (fdDocId fd) (fdZone fd) ep) parseDownloadUrl + contentReq <- getReqFromUrl url + contentResp <- rawRequest api contentReq + checkStatus contentResp + pure $ responseBody contentResp + + +-- | Create a new folder under the given parent node. +execCreateFolder :: Api -> DriveEndpoints -> DriveNodeId -> Text -> IO () +execCreateFolder api ep parentId name = do + resp <- rawRequest api req + checkStatus resp + where + req = + (createFolderReq ep) + { requestBody = RequestBodyLBS (createFolderBody ep parentId name) + , requestHeaders = (hContentType, "application/json") : requestHeaders (createFolderReq ep) + } + + +-- | Rename a drive node (folder or file). +execRenameNode :: Api -> DriveEndpoints -> DriveNode -> Text -> IO () +execRenameNode api ep node name = do + resp <- rawRequest api req + checkStatus resp + where + req = + (renameNodeReq ep) + { requestBody = RequestBodyLBS (renameNodeBody (nodeId node) (nodeEtag node) name) + , requestHeaders = (hContentType, "application/json") : requestHeaders (renameNodeReq ep) + } + + +-- | Move a drive node (folder or file) to the trash. +execDeleteNode :: Api -> DriveEndpoints -> DriveNode -> IO () +execDeleteNode api ep node = do + resp <- rawRequest api req + checkStatus resp + where + req = + (deleteNodeReq ep) + { requestBody = RequestBodyLBS (deleteNodeBody ep (nodeId node) (nodeEtag node)) + , requestHeaders = (hContentType, "application/json") : requestHeaders (deleteNodeReq ep) + } + + +{- | Upload file content into a folder using the 3-step iCloud Drive upload +protocol. +-} +execUploadFile :: Api -> DriveEndpoints -> FolderData -> Text -> LBS.ByteString -> IO () +execUploadFile api ep folder filename content = do + let zone = fnZone folder + tokenBody = uploadTokenBodyBytes filename (LBS.length content) + tokenReq' = + (uploadTokenReq zone ep) + { requestBody = RequestBodyLBS tokenBody + , requestHeaders = (hContentType, "text/plain") : requestHeaders (uploadTokenReq zone ep) + } + (docId, uploadUrl) <- fetchWith "uploadFile (token)" api tokenReq' parseUploadTokenResponse + uploadReq <- buildUploadReq filename content uploadUrl + receipt <- fetchWith "uploadFile (content)" api uploadReq parseUploadReceiptResponse + nowMs <- currentTimeMs + let fDocId = folderDocId folder + commitBody = buildCommitBody docId fDocId filename receipt nowMs + commitReq' = + (commitUploadReq zone ep) + { requestBody = RequestBodyLBS commitBody + , requestHeaders = (hContentType, "text/plain") : requestHeaders (commitUploadReq zone ep) + } + commitResp <- rawRequest api commitReq' + checkStatus commitResp + + +uploadTokenBodyBytes :: Text -> Int64 -> LBS.ByteString +uploadTokenBodyBytes filename size = + encode $ + object + [ "filename" .= filename + , "type" .= ("FILE" :: Text) + , "content_type" .= ("" :: Text) + , "size" .= size + ] + + +buildUploadReq :: Text -> LBS.ByteString -> Text -> IO Request +buildUploadReq filename content url = do + baseReq <- getReqFromUrl url + let part = + (partLBS filename content) + { partFilename = Just (Text.unpack filename) + , partContentType = Just "application/octet-stream" + } + formDataBody [part] baseReq + + +buildCommitBody :: Text -> Text -> Text -> UploadReceipt -> Int64 -> LBS.ByteString +buildCommitBody docId folderId filename receipt nowMs = + encode $ + object + [ "data" .= dataObj + , "command" .= ("add_file" :: Text) + , "create_short_guid" .= True + , "document_id" .= docId + , "path" + .= object + [ "starting_document_id" .= folderId + , "path" .= filename + ] + , "allow_conflict" .= True + , "file_flags" + .= object + [ "is_writable" .= True + , "is_executable" .= False + , "is_hidden" .= False + ] + , "mtime" .= nowMs + , "btime" .= nowMs + ] + where + dataObj = object $ baseData ++ receiptField + baseData = + [ "signature" .= urFileChecksum receipt + , "wrapping_key" .= urWrappingKey receipt + , "reference_signature" .= urReferenceChecksum receipt + , "size" .= urSize receipt + ] + receiptField = case urReceipt receipt of + Nothing -> [] + Just r -> ["receipt" .= r] + + +currentTimeMs :: IO Int64 +currentTimeMs = do + t <- getPOSIXTime + pure $ round (t * 1000) + + +nodeReq :: DriveEndpoints -> DriveNodeId -> Request +nodeReq ep nid = + base + { requestBody = RequestBodyLBS (nodeDetailsBody nid) + , requestHeaders = (hContentType, "application/json") : requestHeaders base + } + where + base = nodeDetailsReq ep + + +getReqFromUrl :: Text -> IO Request +getReqFromUrl = parseRequest . Text.unpack + + +fetchWith :: String -> Api -> Request -> (Value -> Parser a) -> IO a +fetchWith ctx api r parseF = do + resp <- rawRequest api r + checkStatus resp + case eitherDecode (responseBody resp) of + Left err -> throwIO (DriveParseError (ctx <> ": JSON decode error: " <> err)) + Right val -> either (throwIO . DriveParseError) pure $ parseEither parseF val + + +checkStatus :: Response a -> IO () +checkStatus resp = + let code = statusCode (responseStatus resp) + in when (code >= 400) $ throwIO (DriveHttpError code) diff --git a/src-internal/Network/HStratus/Internal/Drive/Endpoints.hs b/src-internal/Network/HStratus/Internal/Drive/Endpoints.hs new file mode 100644 --- /dev/null +++ b/src-internal/Network/HStratus/Internal/Drive/Endpoints.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK prune #-} + +{- | +Module : Network.HStratus.Internal.Drive.Endpoints +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD-3-Clause + +Request builders and endpoint configuration for the iCloud Drive API. +-} +module Network.HStratus.Internal.Drive.Endpoints + ( DriveEndpoints + , mkDriveEndpoints + , nodeDetailsReq + , nodeDetailsBody + , downloadTokenReq + , createFolderReq + , createFolderBody + , renameNodeReq + , renameNodeBody + , deleteNodeReq + , deleteNodeBody + , uploadTokenReq + , commitUploadReq + ) +where + +import Data.Aeson (encode, object, (.=)) +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Network.HStratus.Http.Common + ( icloudBrowserHeaders + , lookupWebservice + , stripTrailingSlash + , withHeaders + ) +import Network.HStratus.Internal.Drive.Node (DriveNodeId (..)) +import Network.HStratus.Session (AccountData (..), Session (..)) +import Network.HTTP.Client + ( Request (..) + ) +import Network.HTTP.Types (methodGet, methodPost, urlEncode) + + +-- | Base requests and client ID needed to call the iCloud Drive API. +data DriveEndpoints = DriveEndpoints + { deServiceReq :: !Request + -- ^ base request targeting the Drive service root (@drivews@) + , deDocReq :: !Request + -- ^ base request targeting the document root (@docws@) + , deClientId :: !Text + -- ^ client ID sent as a query parameter with every request + } + + +{- | Construct 'DriveEndpoints' from the account data returned after login. + +Fails if the @drivews@ or @docws@ service URLs are absent from the account +data. +-} +mkDriveEndpoints :: AccountData -> Session -> IO DriveEndpoints +mkDriveEndpoints ad sess = do + svcReq <- lookupWebservice "drivews" (adWebservices ad) + docReq <- lookupWebservice "docws" (adWebservices ad) + let deServiceReq = withHeaders icloudBrowserHeaders svcReq + deDocReq = withHeaders icloudBrowserHeaders docReq + deClientId = sessionClientId sess + pure DriveEndpoints{deServiceReq, deDocReq, deClientId} + + +-- | Build the @POST retrieveItemDetailsInFolders@ request. +nodeDetailsReq :: DriveEndpoints -> Request +nodeDetailsReq ep = + withClientId ep $ + (deServiceReq ep) + { path = stripTrailingSlash (path (deServiceReq ep)) <> "/retrieveItemDetailsInFolders" + , method = methodPost + } + + +-- | Build the JSON request body for @retrieveItemDetailsInFolders@. +nodeDetailsBody :: DriveNodeId -> LBS.ByteString +nodeDetailsBody (DriveNodeId nid) = + encode [object ["drivewsid" .= nid, "partialData" .= False]] + + +-- | Build the @GET download/by_id@ request for a file in the given zone. +downloadTokenReq :: Text -> Text -> DriveEndpoints -> Request +downloadTokenReq docId zone ep = + (deDocReq ep) + { path = stripTrailingSlash (path (deDocReq ep)) <> "/ws/" <> urlEncode False (encodeUtf8 zone) <> "/download/by_id" + , method = methodGet + , queryString = + "clientId=" + <> urlEncode True (encodeUtf8 (deClientId ep)) + <> "&document_id=" + <> urlEncode True (encodeUtf8 docId) + } + + +-- | Build the @POST createFolders@ request. +createFolderReq :: DriveEndpoints -> Request +createFolderReq ep = + withClientId ep $ + (deServiceReq ep) + { path = stripTrailingSlash (path (deServiceReq ep)) <> "/createFolders" + , method = methodPost + } + + +-- | Build the JSON request body for @createFolders@. +createFolderBody :: DriveEndpoints -> DriveNodeId -> Text -> LBS.ByteString +createFolderBody ep (DriveNodeId parentId) name = + encode $ + object + [ "destinationDrivewsId" .= parentId + , "folders" .= [object ["clientId" .= deClientId ep, "name" .= name]] + ] + + +-- | Build the @POST renameItems@ request. +renameNodeReq :: DriveEndpoints -> Request +renameNodeReq ep = + withClientId ep $ + (deServiceReq ep) + { path = stripTrailingSlash (path (deServiceReq ep)) <> "/renameItems" + , method = methodPost + } + + +-- | Build the JSON request body for @renameItems@. +renameNodeBody :: DriveNodeId -> Text -> Text -> LBS.ByteString +renameNodeBody (DriveNodeId nid) etag name = + encode $ + object + ["items" .= [object ["drivewsid" .= nid, "etag" .= etag, "name" .= name]]] + + +-- | Build the @POST moveItemsToTrash@ request. +deleteNodeReq :: DriveEndpoints -> Request +deleteNodeReq ep = + withClientId ep $ + (deServiceReq ep) + { path = stripTrailingSlash (path (deServiceReq ep)) <> "/moveItemsToTrash" + , method = methodPost + } + + +-- | Build the JSON request body for @moveItemsToTrash@. +deleteNodeBody :: DriveEndpoints -> DriveNodeId -> Text -> LBS.ByteString +deleteNodeBody ep (DriveNodeId nid) etag = + encode $ + object + ["items" .= [object ["drivewsid" .= nid, "etag" .= etag, "clientId" .= deClientId ep]]] + + +-- | Build the @POST upload/web@ request for the given zone. +uploadTokenReq :: Text -> DriveEndpoints -> Request +uploadTokenReq zone ep = + withClientId ep $ + (deDocReq ep) + { path = + stripTrailingSlash (path (deDocReq ep)) + <> "/ws/" + <> urlEncode False (encodeUtf8 zone) + <> "/upload/web" + , method = methodPost + } + + +-- | Build the @POST update/documents@ commit request for the given zone. +commitUploadReq :: Text -> DriveEndpoints -> Request +commitUploadReq zone ep = + withClientId ep $ + (deDocReq ep) + { path = + stripTrailingSlash (path (deDocReq ep)) + <> "/ws/" + <> urlEncode False (encodeUtf8 zone) + <> "/update/documents" + , method = methodPost + } + + +withClientId :: DriveEndpoints -> Request -> Request +withClientId ep req = + let cid = "clientId=" <> urlEncode True (encodeUtf8 (deClientId ep)) + qs = queryString req + in req{queryString = cid <> (if qs == "" then "" else "&" <> qs)} diff --git a/src-internal/Network/HStratus/Internal/Drive/Node.hs b/src-internal/Network/HStratus/Internal/Drive/Node.hs new file mode 100644 --- /dev/null +++ b/src-internal/Network/HStratus/Internal/Drive/Node.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# OPTIONS_HADDOCK prune #-} + +{- | +Module : Network.HStratus.Internal.Drive.Node +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD-3-Clause + +Internal types for iCloud Drive nodes: identifiers, file and folder data. +-} +module Network.HStratus.Internal.Drive.Node + ( -- * Node identifier + DriveNodeId (..) + , rootNodeId + + -- * Node types + , DriveNode (..) + , FolderData (..) + , FileData (..) + , fileName + , nodeId + , nodeEtag + , folderDocId + + -- * Node lookup + , matchFolderName + , selectFileNode + ) +where + +import Data.Int (Int64) +import Data.List (find) +import Data.Maybe (fromMaybe) +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (UTCTime) + + +-- | Stable identifier for a node in iCloud Drive (the @drivewsid@ field). +newtype DriveNodeId = DriveNodeId {unDriveNodeId :: Text} + deriving (Eq, Show) + + +instance IsString DriveNodeId where + fromString = DriveNodeId . Text.pack + + +-- | The node ID for the root of the main CloudDocs tree. +rootNodeId :: DriveNodeId +rootNodeId = DriveNodeId "FOLDER::com.apple.CloudDocs::root" + + +-- | A node in the iCloud Drive tree — either a folder or a file. +data DriveNode + = -- | a folder node with its metadata + DriveFolder FolderData + | -- | a file node with its metadata + DriveFile FileData + deriving (Eq, Show) + + +-- | Metadata for a folder node. +data FolderData = FolderData + { fnId :: !DriveNodeId + -- ^ stable node identifier (@drivewsid@) + , fnEtag :: !Text + -- ^ version tag; required for rename and delete + , fnName :: !Text + -- ^ display name of the folder + , fnZone :: !Text + -- ^ CloudDocs zone (e.g. @com.apple.CloudDocs@) + , fnDateCreated :: !(Maybe UTCTime) + -- ^ creation timestamp; @Nothing@ when absent from the server response + } + deriving (Eq, Show) + + +-- | Metadata for a file node. +data FileData = FileData + { fdId :: !DriveNodeId + -- ^ stable node identifier (@drivewsid@) + , fdDocId :: !Text + -- ^ document identifier (@docwsid@); used for download and upload + , fdEtag :: !Text + -- ^ version tag; required for rename and delete + , fdName :: !Text + -- ^ base file name (without extension) + , fdExtension :: !(Maybe Text) + -- ^ file extension, if present + , fdZone :: !Text + -- ^ CloudDocs zone (e.g. @com.apple.CloudDocs@) + , fdSize :: !(Maybe Int64) + -- ^ file size in bytes; @Nothing@ for zero-byte files + , fdDateCreated :: !(Maybe UTCTime) + -- ^ creation timestamp; @Nothing@ when absent from the server response + , fdDateModified :: !(Maybe UTCTime) + -- ^ last modification timestamp; @Nothing@ when absent from the server response + } + deriving (Eq, Show) + + +-- | The full display name of a file, with extension appended if present. +fileName :: FileData -> Text +fileName fd = case fdExtension fd of + Nothing -> fdName fd + Just ext -> fdName fd <> Text.pack "." <> ext + + +-- | True when the node is a folder whose display name equals the given text. +matchFolderName :: Text -> DriveNode -> Bool +matchFolderName name (DriveFolder fd) = fnName fd == name +matchFolderName _ (DriveFile _) = False + + +-- | Find the first node whose name matches, checking file and folder names. +selectFileNode :: Text -> [DriveNode] -> Maybe DriveNode +selectFileNode name = find matchesName + where + matchesName (DriveFile fd) = fileName fd == name + matchesName (DriveFolder fd) = fnName fd == name + + +-- | Extract the stable identifier from any node. +nodeId :: DriveNode -> DriveNodeId +nodeId (DriveFolder fd) = fnId fd +nodeId (DriveFile fd) = fdId fd + + +-- | Extract the version tag from any node. +nodeEtag :: DriveNode -> Text +nodeEtag (DriveFolder fd) = fnEtag fd +nodeEtag (DriveFile fd) = fdEtag fd + + +-- | Derive the @docwsid@ of a folder from its 'DriveNodeId' and zone. +folderDocId :: FolderData -> Text +folderDocId fd = + let DriveNodeId nid = fnId fd + prefix = "FOLDER::" <> fnZone fd <> "::" + in fromMaybe nid (Text.stripPrefix prefix nid) diff --git a/src-internal/Network/HStratus/Internal/Drive/NodeData.hs b/src-internal/Network/HStratus/Internal/Drive/NodeData.hs new file mode 100644 --- /dev/null +++ b/src-internal/Network/HStratus/Internal/Drive/NodeData.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK prune #-} + +{- | +Module : Network.HStratus.Internal.Drive.NodeData +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD-3-Clause + +JSON parsers for iCloud Drive API responses: node metadata, download URLs, and upload receipts. +-} +module Network.HStratus.Internal.Drive.NodeData + ( parseNodeResponse + , parseChildrenResponse + , parseDownloadUrl + , UploadReceipt (..) + , parseUploadTokenResponse + , parseUploadReceiptResponse + ) +where + +import Data.Aeson + ( Object + , Value + , withArray + , withObject + , (.:) + , (.:?) + ) +import Data.Aeson.Types (Parser) +import Data.Functor ((<&>)) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (UTCTime, ZonedTime, zonedTimeToUTC) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import qualified Data.Vector as V +import Network.HStratus.Internal.Drive.Node + ( DriveNode (..) + , DriveNodeId (..) + , FileData (..) + , FolderData (..) + ) + + +{- | Parse the first element of a @retrieveItemDetailsInFolders@ response as a +@DriveNode@. +-} +parseNodeResponse :: Value -> Parser DriveNode +parseNodeResponse = withArray "node response" $ \arr -> + case V.toList arr of + [] -> fail "retrieveItemDetailsInFolders: empty response array" + (v : _) -> parseNode v + + +{- | Parse the children from the first element of a +@retrieveItemDetailsInFolders@ response. +-} +parseChildrenResponse :: Value -> Parser [DriveNode] +parseChildrenResponse = withArray "children response" $ \arr -> + case V.toList arr of + [] -> fail "retrieveItemDetailsInFolders: empty response array" + (v : _) -> withObject "folder" parseItems v + + +-- | Extract the download URL from a @download/by_id@ response. +parseDownloadUrl :: Value -> Parser Text +parseDownloadUrl = withObject "download response" $ \o -> do + dataToken <- o .:? "data_token" + pkgToken <- o .:? "package_token" + case (dataToken, pkgToken) of + (Just dt, _) -> withObject "data_token" (.: "url") dt + (_, Just pt) -> withObject "package_token" (.: "url") pt + _other -> fail "download response: neither data_token nor package_token found" + + +parseNode :: Value -> Parser DriveNode +parseNode = withObject "DriveNode" $ \o -> do + nodeType <- o .: "type" :: Parser Text + case nodeType of + "FILE" -> DriveFile <$> parseFileData o + "FOLDER" -> DriveFolder <$> parseFolderData o + "APP_LIBRARY" -> DriveFolder <$> parseFolderData o + other -> fail $ "DriveNode: unknown node type: " <> Text.unpack other + + +parseFolderData :: Object -> Parser FolderData +parseFolderData o = + (FolderData . DriveNodeId <$> (o .: "drivewsid")) + <*> o .: "etag" + <*> o .: "name" + <*> o .: "zone" + <*> (o .:? "dateCreated" >>= traverse parseTimestamp) + + +parseFileData :: Object -> Parser FileData +parseFileData o = + (FileData . DriveNodeId <$> (o .: "drivewsid")) + <*> o .: "docwsid" + <*> o .: "etag" + <*> o .: "name" + <*> o .:? "extension" + <*> o .: "zone" + <*> o .:? "size" + <*> (o .:? "dateCreated" >>= traverse parseTimestamp) + <*> (o .:? "dateModified" >>= traverse parseTimestamp) + + +parseItems :: Object -> Parser [DriveNode] +parseItems o = do + items <- (o .:? "items") <&> fromMaybe [] + mapM parseNode items + + +-- | Checksum metadata returned after uploading file content (step 2 of upload). +data UploadReceipt = UploadReceipt + { urFileChecksum :: !Text + -- ^ SHA-256 checksum of the uploaded file + , urWrappingKey :: !Text + -- ^ encryption wrapping key returned by the upload endpoint + , urReferenceChecksum :: !Text + -- ^ reference checksum used in the commit body + , urSize :: !Int64 + -- ^ byte size of the uploaded content + , urReceipt :: !(Maybe Text) + -- ^ opaque receipt token; @Nothing@ when absent from the server response + } + + +-- | Parse the @upload/web@ response to extract @(document_id, upload_url)@. +parseUploadTokenResponse :: Value -> Parser (Text, Text) +parseUploadTokenResponse = withArray "upload token response" $ \arr -> + case V.toList arr of + [] -> fail "upload token response: empty array" + (v : _) -> + withObject "upload token" (\o -> (,) <$> o .: "document_id" <*> o .: "url") v + + +-- | Parse the multipart-upload response body to extract 'UploadReceipt'. +parseUploadReceiptResponse :: Value -> Parser UploadReceipt +parseUploadReceiptResponse = withObject "upload receipt response" $ \o -> do + sf <- o .: "singleFile" + withObject "singleFile" parseReceiptFields sf + + +parseReceiptFields :: Object -> Parser UploadReceipt +parseReceiptFields o = + UploadReceipt + <$> o .: "fileChecksum" + <*> o .: "wrappingKey" + <*> o .: "referenceChecksum" + <*> o .: "size" + <*> o .:? "receipt" + + +-- | Parse an ISO 8601 timestamp in either UTC (@Z@) or offset (@±HH:MM@) form. +parseTimestamp :: Text -> Parser UTCTime +parseTimestamp t = + let s = Text.unpack t + in case (iso8601ParseM s :: Maybe UTCTime) of + Just ut -> pure ut + Nothing -> case (iso8601ParseM s :: Maybe ZonedTime) of + Just zt -> pure (zonedTimeToUTC zt) + Nothing -> fail $ "invalid ISO 8601 timestamp: " <> s diff --git a/src/Network/HStratus/Drive.hs b/src/Network/HStratus/Drive.hs new file mode 100644 --- /dev/null +++ b/src/Network/HStratus/Drive.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE NamedFieldPuns #-} + +{- | +Module : Network.HStratus.Drive +Copyright : (c) 2025 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Access iCloud Drive using an authenticated session from @hstratus-auth@. + +After a successful login with 'Network.HStratus.Http.login', construct a +'DriveApi' value from the returned 'AccountData', 'Session', and 'Api' +handle, then use it to browse and download files. + +@ +import Network.HStratus.Http (login, mkApi) +import Network.HStratus.Http.Endpoints (Realm (..)) +import Network.HStratus.Drive + +main :: IO () +main = do + api <- mkApi Usual + Authenticated sess ad <- login api + da <- mkDriveApi ad sess api + root <- driveRoot da + nodes <- listFolder da (fnId root) + print nodes +@ +-} +module Network.HStratus.Drive + ( -- * Setup + DriveApi + , mkDriveApi + + -- * Browsing + , driveRoot + , listFolder + + -- * Downloading + , downloadFile + + -- * Mutations + , createFolder + , renameNode + , deleteNode + , uploadFile + + -- * Errors + , DriveError (..) + + -- * Re-exports + , module Network.HStratus.Drive.Node + ) +where + +import Control.Exception (throwIO) +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) +import Network.HStratus.Drive.Node +import Network.HStratus.Http (Api) +import Network.HStratus.Internal.Drive.Download + ( DriveError (..) + , execCreateFolder + , execDeleteNode + , execRenameNode + , execUploadFile + , fetchChildren + , fetchFile + , fetchNode + ) +import Network.HStratus.Internal.Drive.Endpoints + ( DriveEndpoints + , mkDriveEndpoints + ) +import Network.HStratus.Session (AccountData, Session) + + +{- | A bundled handle pairing a logged-in 'Api' with its drive endpoints. +Construct with 'mkDriveApi'; pass to all drive operations. +-} +data DriveApi = DriveApi + { dApi :: !Api + , dEp :: !DriveEndpoints + } + + +-- | Pair a logged-in 'Api' with drive endpoints derived from its session data. +mkDriveApi :: AccountData -> Session -> Api -> IO DriveApi +mkDriveApi ad sess api = DriveApi api <$> mkDriveEndpoints ad sess + + +-- | Fetch the root folder of the main CloudDocs tree. +driveRoot :: DriveApi -> IO FolderData +driveRoot DriveApi{dApi, dEp} = do + node <- fetchNode dApi dEp rootNodeId + case node of + DriveFolder fd -> pure fd + DriveFile _ -> throwIO DriveInvalidRoot + + +-- | Fetch the immediate children of a folder. +listFolder :: DriveApi -> DriveNodeId -> IO [DriveNode] +listFolder DriveApi{dApi, dEp} = fetchChildren dApi dEp + + +-- | Download the contents of a file as a lazy 'LBS.ByteString'. +downloadFile :: DriveApi -> FileData -> IO LBS.ByteString +downloadFile DriveApi{dApi, dEp} = fetchFile dApi dEp + + +-- | Create a new folder inside an existing folder. +createFolder :: DriveApi -> DriveNodeId -> Text -> IO () +createFolder DriveApi{dApi, dEp} = execCreateFolder dApi dEp + + +-- | Rename a node (folder or file) to a new name. +renameNode :: DriveApi -> DriveNode -> Text -> IO () +renameNode DriveApi{dApi, dEp} = execRenameNode dApi dEp + + +-- | Move a node (folder or file) to the trash. +deleteNode :: DriveApi -> DriveNode -> IO () +deleteNode DriveApi{dApi, dEp} = execDeleteNode dApi dEp + + +-- | Upload a file into a folder. +uploadFile :: DriveApi -> FolderData -> Text -> LBS.ByteString -> IO () +uploadFile DriveApi{dApi, dEp} = execUploadFile dApi dEp diff --git a/src/Network/HStratus/Drive/Node.hs b/src/Network/HStratus/Drive/Node.hs new file mode 100644 --- /dev/null +++ b/src/Network/HStratus/Drive/Node.hs @@ -0,0 +1,46 @@ +{- | +Module : Network.HStratus.Drive.Node +Copyright : (c) 2025 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD3 + +Types representing nodes in the iCloud Drive file tree. + +Every item in Drive is either a 'FolderData' or a 'FileData', wrapped in a +'DriveNode'. Folders are identified by a 'DriveNodeId'; files additionally +carry a document identifier used for download. + +Use 'rootNodeId' to address the root of the main CloudDocs tree. +-} +module Network.HStratus.Drive.Node + ( -- * Node sum type + DriveNode (..) + + -- * Folder + , FolderData (..) + + -- * File + , FileData (..) + , fileName + + -- * Identifiers + , DriveNodeId (..) + , rootNodeId + + -- * Node lookup + , matchFolderName + , selectFileNode + ) +where + +import Network.HStratus.Internal.Drive.Node + ( DriveNode (..) + , DriveNodeId (..) + , FileData (..) + , FolderData (..) + , fileName + , matchFolderName + , rootNodeId + , selectFileNode + ) + diff --git a/test/HStratus/Drive/EndpointsSpec.hs b/test/HStratus/Drive/EndpointsSpec.hs new file mode 100644 --- /dev/null +++ b/test/HStratus/Drive/EndpointsSpec.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : HStratus.Drive.EndpointsSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD-3-Clause + +Tests for the iCloud Drive CloudKit endpoint and request-body builders. +-} +module HStratus.Drive.EndpointsSpec (spec) where + +import Data.Aeson (Value, decode, object) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Network.HStratus.Internal.Drive.Endpoints + ( downloadTokenReq + , mkDriveEndpoints + , nodeDetailsBody + , nodeDetailsReq + ) +import Network.HStratus.Internal.Drive.Node (DriveNodeId (..), rootNodeId) +import Network.HStratus.Session (AccountData (..), Credentials (..), Session (..), Webservice (..)) +import Network.HTTP.Client (Request (..)) +import Network.HTTP.Types (methodGet, methodPost) +import Test.Hspec + + +spec :: Spec +spec = describe "Network.HStratus.Internal.Drive.Endpoints" $ do + ep <- runIO (mkDriveEndpoints testAccountData testSession) + + describe "nodeDetailsBody" $ do + it "encodes the node id and partialData=false" $ + nodeDetailsBody rootNodeId + `shouldBe` ( "[{\"drivewsid\":\"FOLDER::com.apple.CloudDocs::root\"" + <> ",\"partialData\":false}]" + :: LBS.ByteString + ) + it "produces valid JSON for node ids containing quotes or backslashes" $ + (decode (nodeDetailsBody (DriveNodeId "folder/with\"quote\\here")) :: Maybe Value) + `shouldNotBe` Nothing + + describe "nodeDetailsReq" $ do + it "targets retrieveItemDetailsInFolders" $ + path (nodeDetailsReq ep) + `shouldSatisfy` BS.isSuffixOf "/retrieveItemDetailsInFolders" + it "uses POST" $ + method (nodeDetailsReq ep) `shouldBe` methodPost + it "includes clientId query param" $ + queryString (nodeDetailsReq ep) + `shouldSatisfy` BS.isInfixOf "clientId=auth-test-client-id" + + describe "downloadTokenReq" $ do + let req = downloadTokenReq "DOC-001" "com.apple.CloudDocs" ep + it "targets /ws//download/by_id" $ + path req + `shouldSatisfy` BS.isSuffixOf "/ws/com.apple.CloudDocs/download/by_id" + it "uses GET" $ + method req `shouldBe` methodGet + it "includes clientId in query string" $ + queryString req `shouldSatisfy` BS.isInfixOf "clientId=auth-test-client-id" + it "includes document_id in query string" $ + queryString req `shouldSatisfy` BS.isInfixOf "document_id=DOC-001" + + +-- Fixtures + +testClientId :: Text +testClientId = "auth-test-client-id" + + +testAccountData :: AccountData +testAccountData = + AccountData + { adHsaVersion = 2 + , adHsaChallengeRequired = False + , adHsaTrustedBrowser = Just True + , adWebservices = + Map.fromList + [ ("drivews", Webservice "https://p31-drivews.icloud.com" Nothing) + , ("docws", Webservice "https://p31-docws.icloud.com" Nothing) + ] + , adRaw = object [] + } + + +testSession :: Session +testSession = + Session + { sessionCreds = Credentials{credAccountName = "test@example.com", credPassword = "test-pass"} + , sessionTopDir = "/tmp/test" + , sessionClientId = testClientId + } diff --git a/test/HStratus/Drive/MutationSpec.hs b/test/HStratus/Drive/MutationSpec.hs new file mode 100644 --- /dev/null +++ b/test/HStratus/Drive/MutationSpec.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : HStratus.Drive.MutationSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD-3-Clause + +Tests for iCloud Drive mutation operations (rename, move, delete). +-} +module HStratus.Drive.MutationSpec (spec) where + +import Data.Aeson (object) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import Network.HStratus.Drive +import Network.HStratus.Http (mkApiWith) +import Network.HStratus.Http.Endpoints (Endpoints (..)) +import Network.HStratus.Session (AccountData (..), Credentials (..), Session (..), Webservice (..)) +import Network.HTTP.Client + ( Request (..) + , defaultManagerSettings + , defaultRequest + , newManager + ) +import Network.HTTP.Types (HeaderName, hContentType, methodPost, status200, status400) +import Network.Wai (Application, rawPathInfo, responseLBS) +import Network.Wai.Handler.Warp (testWithApplication) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + + +spec :: Spec +spec = describe "Network.HStratus.Drive" $ do + describe "createFolder" $ do + it "returns () on success" $ + withMock createOkApp $ \da -> + createFolder da rootNodeId "New Folder" `shouldReturn` () + it "raises an error on HTTP failure" $ + withMock errorApp $ \da -> + createFolder da rootNodeId "New Folder" `shouldThrow` anyException + + describe "renameNode" $ do + it "returns () when renaming a folder" $ + withMock renameOkApp $ \da -> + renameNode da testFolderNode "Renamed Folder" `shouldReturn` () + it "returns () when renaming a file" $ + withMock renameOkApp $ \da -> + renameNode da testFileNode "Renamed File" `shouldReturn` () + it "raises an error on HTTP failure" $ + withMock errorApp $ \da -> + renameNode da testFolderNode "Renamed Folder" `shouldThrow` anyException + + describe "deleteNode" $ do + it "returns () when deleting a folder" $ + withMock deleteOkApp $ \da -> + deleteNode da testFolderNode `shouldReturn` () + it "returns () when deleting a file" $ + withMock deleteOkApp $ \da -> + deleteNode da testFileNode `shouldReturn` () + it "raises an error on HTTP failure" $ + withMock errorApp $ \da -> + deleteNode da testFolderNode `shouldThrow` anyException + + +-- Mock servers + +withMock :: Application -> (DriveApi -> IO a) -> IO a +withMock app action = + withSystemTempDirectory "icloud-drive-mutation" $ \tmpDir -> + testWithApplication (pure app) $ \serverPort -> do + da <- mkEpAndApi serverPort tmpDir + action da + + +createOkApp :: Application +createOkApp req respond + | "/createFolders" `BS.isSuffixOf` rawPathInfo req = + respond $ responseLBS status200 jsonHeaders "{}" + | otherwise = + respond $ responseLBS status400 [] "unexpected path" + + +renameOkApp :: Application +renameOkApp req respond + | "/renameItems" `BS.isSuffixOf` rawPathInfo req = + respond $ responseLBS status200 jsonHeaders "{}" + | otherwise = + respond $ responseLBS status400 [] "unexpected path" + + +deleteOkApp :: Application +deleteOkApp req respond + | "/moveItemsToTrash" `BS.isSuffixOf` rawPathInfo req = + respond $ responseLBS status200 jsonHeaders "{}" + | otherwise = + respond $ responseLBS status400 [] "unexpected path" + + +errorApp :: Application +errorApp _req respond = respond $ responseLBS status400 [] "bad request" + + +mkEpAndApi :: Int -> FilePath -> IO DriveApi +mkEpAndApi serverPort tmpDir = do + let baseUrl = Text.pack $ "http://127.0.0.1:" ++ show serverPort + mgr <- newManager defaultManagerSettings + api <- mkApiWith (testSession tmpDir) (testAuthEndpoints serverPort) mgr + mkDriveApi (testAccountData baseUrl) (testSession tmpDir) api + + +-- Fixtures + +testAccountData :: Text.Text -> AccountData +testAccountData baseUrl = + AccountData + { adHsaVersion = 2 + , adHsaChallengeRequired = False + , adHsaTrustedBrowser = Just True + , adWebservices = Map.fromList [("drivews", Webservice baseUrl Nothing), ("docws", Webservice baseUrl Nothing)] + , adRaw = object [] + } + + +testSession :: FilePath -> Session +testSession topDir = + Session + { sessionCreds = Credentials{credAccountName = "test@example.com", credPassword = "test-pass"} + , sessionTopDir = topDir + , sessionClientId = "auth-test-client-id" + } + + +testAuthEndpoints :: Int -> Endpoints +testAuthEndpoints serverPort = + Endpoints + { epHome = "http://127.0.0.1:" <> BS8.pack (show serverPort) + , epAuth = dummyReq "/appleauth/auth" + , epSetup = dummyReq "/setup/ws/1" + , epWidgetKey = "test-widget-key" + } + where + dummyReq reqPath = + defaultRequest + { host = "127.0.0.1" + , port = serverPort + , secure = False + , method = methodPost + , path = reqPath + } + + +testFolderNode :: DriveNode +testFolderNode = + DriveFolder + FolderData + { fnId = DriveNodeId "FOLDER::com.apple.CloudDocs::test-folder" + , fnEtag = "1a" + , fnName = "Test Folder" + , fnZone = "com.apple.CloudDocs" + , fnDateCreated = Nothing + } + + +testFileNode :: DriveNode +testFileNode = + DriveFile + FileData + { fdId = DriveNodeId "FILE::com.apple.CloudDocs::test-file" + , fdDocId = "test-file-doc-id" + , fdEtag = "2b" + , fdName = "Test File" + , fdExtension = Just "txt" + , fdZone = "com.apple.CloudDocs" + , fdSize = Just 100 + , fdDateCreated = Nothing + , fdDateModified = Nothing + } + + +jsonHeaders :: [(HeaderName, BS8.ByteString)] +jsonHeaders = [(hContentType, "application/json")] diff --git a/test/HStratus/Drive/NodeSpec.hs b/test/HStratus/Drive/NodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/HStratus/Drive/NodeSpec.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : HStratus.Drive.NodeSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD-3-Clause + +Tests for iCloud Drive node JSON decoding and data model. +-} +module HStratus.Drive.NodeSpec (spec) where + +import Data.Aeson (Value, eitherDecode) +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Network.HStratus.Internal.Drive.Node + ( DriveNode (..) + , DriveNodeId (..) + , FileData (..) + , FolderData (..) + ) +import Network.HStratus.Internal.Drive.NodeData + ( parseChildrenResponse + , parseDownloadUrl + , parseNodeResponse + ) +import Test.Hspec + + +spec :: Spec +spec = describe "Network.HStratus.Internal.Drive.NodeData" $ do + describe "parseNodeResponse" $ do + it "parses a root folder" $ do + v <- decodeOrFail rootFolderJson + parseEither parseNodeResponse v + `shouldBe` Right (DriveFolder rootFolderData) + it "parses APP_LIBRARY type as DriveFolder" $ do + v <- decodeOrFail appLibraryJson + case parseEither parseNodeResponse v of + Left err -> expectationFailure err + Right (DriveFile _) -> expectationFailure "expected DriveFolder for APP_LIBRARY" + Right (DriveFolder fd) -> + fnId fd `shouldBe` DriveNodeId "FOLDER::com.apple.Keynote::documents" + it "fails with an informative message for an unknown type" $ do + v <- decodeOrFail unknownTypeJson + case parseEither parseNodeResponse v of + Left err -> err `shouldContain` "unknown node type: SYMLINK" + Right _ -> expectationFailure "expected parse failure for unknown type" + + describe "parseChildrenResponse" $ do + it "returns empty list when items field is absent" $ do + v <- decodeOrFail rootFolderJson + parseEither parseChildrenResponse v `shouldBe` Right [] + it "returns all children" $ do + v <- decodeOrFail subfolderJson + case parseEither parseChildrenResponse v of + Left err -> expectationFailure err + Right nodes -> length nodes `shouldBe` 2 + it "parses file children with extension, size, and dateModified" $ do + v <- decodeOrFail subfolderJson + case parseEither parseChildrenResponse v of + Left err -> expectationFailure err + Right (DriveFile fd : _) -> do + fdDocId fd `shouldBe` "33A41112-4131-4938-9691-7F356CE3C51D" + fdExtension fd `shouldBe` Just "pdf" + fdSize fd `shouldBe` Just 19876991 + fdDateModified fd `shouldBe` parseTs "2020-04-27T21:37:36Z" + Right nodes -> + expectationFailure $ "expected file as first child, got: " <> show nodes + + describe "parseDownloadUrl" $ do + it "extracts url from data_token" $ do + v <- decodeOrFail dataTokenJson + parseEither parseDownloadUrl v `shouldBe` Right dataTokenUrl + it "falls back to package_token when data_token is absent" $ do + v <- decodeOrFail pkgTokenJson + parseEither parseDownloadUrl v `shouldBe` Right pkgTokenUrl + it "fails when neither token field is present" $ do + v <- decodeOrFail "{\"document_id\":\"516C896C\"}" + case parseEither parseDownloadUrl v of + Left _ -> pure () + Right _ -> expectationFailure "expected parse failure" + + +-- Fixtures + +rootFolderData :: FolderData +rootFolderData = + FolderData + { fnId = DriveNodeId "FOLDER::com.apple.CloudDocs::root" + , fnEtag = "31" + , fnName = "" + , fnZone = "com.apple.CloudDocs" + , fnDateCreated = Nothing + } + + +rootFolderJson :: LBS.ByteString +rootFolderJson = + "[{\"drivewsid\":\"FOLDER::com.apple.CloudDocs::root\"\ + \,\"zone\":\"com.apple.CloudDocs\"\ + \,\"name\":\"\"\ + \,\"etag\":\"31\"\ + \,\"type\":\"FOLDER\"\ + \}]" + + +appLibraryJson :: LBS.ByteString +appLibraryJson = + "[{\"drivewsid\":\"FOLDER::com.apple.Keynote::documents\"\ + \,\"zone\":\"com.apple.Keynote\"\ + \,\"name\":\"Keynote\"\ + \,\"etag\":\"2m\"\ + \,\"type\":\"APP_LIBRARY\"\ + \,\"dateCreated\":\"2019-12-12T14:33:55-08:00\"\ + \}]" + + +unknownTypeJson :: LBS.ByteString +unknownTypeJson = + "[{\"drivewsid\":\"SYMLINK::com.apple.CloudDocs::ABC123\"\ + \,\"zone\":\"com.apple.CloudDocs\"\ + \,\"name\":\"link\"\ + \,\"etag\":\"1a\"\ + \,\"type\":\"SYMLINK\"\ + \}]" + + +subfolderJson :: LBS.ByteString +subfolderJson = + "[{\"drivewsid\":\"FOLDER::com.apple.CloudDocs::D5AA0425-E84F-4501-AF5D-60F1D92648CF\"\ + \,\"zone\":\"com.apple.CloudDocs\"\ + \,\"name\":\"Test\"\ + \,\"etag\":\"2z\"\ + \,\"type\":\"FOLDER\"\ + \,\"items\":[\ + \{\"drivewsid\":\"FILE::com.apple.CloudDocs::33A41112-4131-4938-9691-7F356CE3C51D\"\ + \,\"docwsid\":\"33A41112-4131-4938-9691-7F356CE3C51D\"\ + \,\"zone\":\"com.apple.CloudDocs\"\ + \,\"name\":\"Scan 2\"\ + \,\"dateModified\":\"2020-04-27T21:37:36Z\"\ + \,\"size\":19876991\ + \,\"etag\":\"2k::2j\"\ + \,\"extension\":\"pdf\"\ + \,\"type\":\"FILE\"\ + \}\ + \,{\"drivewsid\":\"FILE::com.apple.CloudDocs::516C896C-6AA5-4A30-B30E-5502C2333DAE\"\ + \,\"docwsid\":\"516C896C-6AA5-4A30-B30E-5502C2333DAE\"\ + \,\"zone\":\"com.apple.CloudDocs\"\ + \,\"name\":\"Scanned document 1\"\ + \,\"dateModified\":\"2020-05-03T00:15:17Z\"\ + \,\"size\":21644358\ + \,\"etag\":\"32::2x\"\ + \,\"extension\":\"pdf\"\ + \,\"type\":\"FILE\"\ + \}\ + \]}]" + + +dataTokenUrl :: Text +dataTokenUrl = "https://cvws.icloud-content.com/B/sig1ref1/Scanned+document+1.pdf?o=obj&v=1" + + +dataTokenJson :: LBS.ByteString +dataTokenJson = + "{\"data_token\":{\"url\":\"https://cvws.icloud-content.com/B/sig1ref1/Scanned+document+1.pdf?o=obj&v=1\"\ + \,\"token\":\"tok1\"\ + \}}" + + +pkgTokenUrl :: Text +pkgTokenUrl = "https://cvws.icloud-content.com/B/sig2ref2/pkg.zip?o=obj&v=1" + + +pkgTokenJson :: LBS.ByteString +pkgTokenJson = + "{\"package_token\":{\"url\":\"https://cvws.icloud-content.com/B/sig2ref2/pkg.zip?o=obj&v=1\"\ + \,\"token\":\"tok2\"\ + \}}" + + +-- Helpers + +decodeOrFail :: LBS.ByteString -> IO Value +decodeOrFail bs = case eitherDecode bs of + Left err -> fail err + Right v -> pure v + + +parseTs :: String -> Maybe UTCTime +parseTs = iso8601ParseM diff --git a/test/HStratus/Drive/UploadSpec.hs b/test/HStratus/Drive/UploadSpec.hs new file mode 100644 --- /dev/null +++ b/test/HStratus/Drive/UploadSpec.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : HStratus.Drive.UploadSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD-3-Clause + +Tests for the iCloud Drive file upload workflow. +-} +module HStratus.Drive.UploadSpec (spec) where + +import Data.Aeson (object) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.IORef (newIORef, readIORef, writeIORef) +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import Network.HStratus.Drive +import Network.HStratus.Http (mkApiWith) +import Network.HStratus.Http.Endpoints (Endpoints (..)) +import Network.HStratus.Session (AccountData (..), Credentials (..), Session (..), Webservice (..)) +import Network.HTTP.Client + ( Request (..) + , defaultManagerSettings + , defaultRequest + , newManager + ) +import Network.HTTP.Types (HeaderName, hContentType, methodPost, status200, status400) +import Network.Wai (Application, rawPathInfo, responseLBS) +import Network.Wai.Handler.Warp (testWithApplication) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + + +spec :: Spec +spec = describe "Network.HStratus.Drive" $ do + describe "uploadFile" $ do + it "returns () on success" $ + withUploadMock uploadOkApp $ \da -> + uploadFile da testFolderData "hello.txt" "hello world" `shouldReturn` () + it "raises an error when the token request fails" $ + withUploadMock errorApp $ \da -> + uploadFile da testFolderData "hello.txt" "hello world" `shouldThrow` anyException + it "raises an error when the content upload fails" $ + withUploadMock contentErrorApp $ \da -> + uploadFile da testFolderData "hello.txt" "hello world" `shouldThrow` anyException + it "raises an error when the commit request fails" $ + withUploadMock commitErrorApp $ \da -> + uploadFile da testFolderData "hello.txt" "hello world" `shouldThrow` anyException + + +-- Mock servers + +withUploadMock :: (Int -> Application) -> (DriveApi -> IO a) -> IO a +withUploadMock mkApp action = + withSystemTempDirectory "icloud-drive-upload" $ \tmpDir -> do + portRef <- newIORef 0 + testWithApplication (pure (dynApp portRef mkApp)) $ \serverPort -> do + writeIORef portRef serverPort + da <- mkEpAndApi serverPort tmpDir + action da + where + dynApp portRef mk req respond = do + serverPort <- readIORef portRef + mk serverPort req respond + + +uploadOkApp :: Int -> Application +uploadOkApp serverPort req respond + | "/upload/web" `BS.isSuffixOf` rawPathInfo req = + let url = "http://127.0.0.1:" ++ show serverPort ++ "/upload/content" + body = LBS8.pack $ "[{\"document_id\":\"test-doc-id\",\"url\":\"" ++ url ++ "\"}]" + in respond $ responseLBS status200 jsonHeaders body + | rawPathInfo req == "/upload/content" = + respond $ responseLBS status200 jsonHeaders receiptJson + | "/update/documents" `BS.isSuffixOf` rawPathInfo req = + respond $ responseLBS status200 jsonHeaders "{}" + | otherwise = + respond $ responseLBS status400 [] "unexpected path" + + +errorApp :: Int -> Application +errorApp _port _req respond = respond $ responseLBS status400 [] "bad request" + + +contentErrorApp :: Int -> Application +contentErrorApp _port req respond + | "/upload/web" `BS.isSuffixOf` rawPathInfo req = + respond $ responseLBS status200 jsonHeaders badTokenJson + | otherwise = + respond $ responseLBS status400 [] "bad request" + where + badTokenJson = "[{\"document_id\":\"x\",\"url\":\"http://127.0.0.1:1/no-such\"}]" + + +commitErrorApp :: Int -> Application +commitErrorApp serverPort req respond + | "/upload/web" `BS.isSuffixOf` rawPathInfo req = + let url = "http://127.0.0.1:" ++ show serverPort ++ "/upload/content" + body = LBS8.pack $ "[{\"document_id\":\"test-doc-id\",\"url\":\"" ++ url ++ "\"}]" + in respond $ responseLBS status200 jsonHeaders body + | rawPathInfo req == "/upload/content" = + respond $ responseLBS status200 jsonHeaders receiptJson + | otherwise = + respond $ responseLBS status400 [] "bad request" + + +mkEpAndApi :: Int -> FilePath -> IO DriveApi +mkEpAndApi serverPort tmpDir = do + let baseUrl = Text.pack $ "http://127.0.0.1:" ++ show serverPort + mgr <- newManager defaultManagerSettings + api <- mkApiWith (testSession tmpDir) (testAuthEndpoints serverPort) mgr + mkDriveApi (testAccountData baseUrl) (testSession tmpDir) api + + +-- Fixtures + +testAccountData :: Text.Text -> AccountData +testAccountData baseUrl = + AccountData + { adHsaVersion = 2 + , adHsaChallengeRequired = False + , adHsaTrustedBrowser = Just True + , adWebservices = Map.fromList [("drivews", Webservice baseUrl Nothing), ("docws", Webservice baseUrl Nothing)] + , adRaw = object [] + } + + +testSession :: FilePath -> Session +testSession topDir = + Session + { sessionCreds = Credentials{credAccountName = "test@example.com", credPassword = "test-pass"} + , sessionTopDir = topDir + , sessionClientId = "auth-test-client-id" + } + + +testAuthEndpoints :: Int -> Endpoints +testAuthEndpoints serverPort = + Endpoints + { epHome = "http://127.0.0.1:" <> BS8.pack (show serverPort) + , epAuth = dummyReq "/appleauth/auth" + , epSetup = dummyReq "/setup/ws/1" + , epWidgetKey = "test-widget-key" + } + where + dummyReq reqPath = + defaultRequest + { host = "127.0.0.1" + , port = serverPort + , secure = False + , method = methodPost + , path = reqPath + } + + +testFolderData :: FolderData +testFolderData = + FolderData + { fnId = DriveNodeId "FOLDER::com.apple.CloudDocs::test-folder-doc" + , fnEtag = "1a" + , fnName = "Test Folder" + , fnZone = "com.apple.CloudDocs" + , fnDateCreated = Nothing + } + + +receiptJson :: LBS.ByteString +receiptJson = + "{\"singleFile\":\ + \{\"fileChecksum\":\"chk\"\ + \,\"wrappingKey\":\"wk\"\ + \,\"referenceChecksum\":\"rc\"\ + \,\"size\":11\ + \,\"receipt\":\"rcpt\"\ + \}}" + + +jsonHeaders :: [(HeaderName, BS8.ByteString)] +jsonHeaders = [(hContentType, "application/json")] diff --git a/test/HStratus/DriveSpec.hs b/test/HStratus/DriveSpec.hs new file mode 100644 --- /dev/null +++ b/test/HStratus/DriveSpec.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : HStratus.DriveSpec +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD-3-Clause + +Integration tests for the iCloud Drive API client. +-} +module HStratus.DriveSpec (spec) where + +import Control.Exception (displayException) +import Data.Aeson (object) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import Network.HStratus.Drive +import Network.HStratus.Http (mkApiWith) +import Network.HStratus.Http.Endpoints (Endpoints (..)) +import Network.HStratus.Session (AccountData (..), Credentials (..), Session (..), Webservice (..)) +import Network.HTTP.Client (Request (..), defaultManagerSettings, defaultRequest, newManager) +import Network.HTTP.Types (HeaderName, hContentType, methodPost, status200, status404) +import Network.Wai (Application, rawPathInfo, responseLBS) +import Network.Wai.Handler.Warp (testWithApplication) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + + +spec :: Spec +spec = describe "Network.HStratus.Drive" $ do + describe "matchFolderName" $ do + it "is True for a DriveFolder with the matching name" $ + matchFolderName "Documents" (DriveFolder testFolderData) `shouldBe` True + it "is False for a DriveFolder with a different name" $ + matchFolderName "Other" (DriveFolder testFolderData) `shouldBe` False + it "is False for a DriveFile" $ + matchFolderName "Documents" (DriveFile testFileData) `shouldBe` False + + describe "selectFileNode" $ do + it "returns Just DriveFile when a file's full name matches" $ + selectFileNode "Scan 2.pdf" testNodes `shouldBe` Just (DriveFile testFileData) + it "returns Just DriveFolder when a folder name matches" $ + selectFileNode "Documents" testNodes `shouldBe` Just (DriveFolder testFolderData) + it "returns Nothing when no node matches" $ + selectFileNode "missing.txt" testNodes `shouldBe` Nothing + + describe "DriveError displayException" $ do + it "DriveHttpError" $ + displayException (DriveHttpError 404) `shouldBe` "iCloud Drive: HTTP error 404" + it "DriveParseError" $ + displayException (DriveParseError "bad json") `shouldBe` "iCloud Drive: parse error: bad json" + it "DriveInvalidRoot" $ + displayException DriveInvalidRoot `shouldBe` "iCloud Drive: invalid root node" + + describe "driveRoot" $ do + it "returns root FolderData" $ + withNodeMock rootJson $ \da -> do + fd <- driveRoot da + fnId fd `shouldBe` DriveNodeId "FOLDER::com.apple.CloudDocs::root" + + describe "listFolder" $ do + it "returns all children" $ + withNodeMock subfolderJson $ \da -> do + nodes <- listFolder da (DriveNodeId "FOLDER::com.apple.CloudDocs::D5AA0425") + length nodes `shouldBe` 2 + it "returns DriveFile nodes for file children" $ + withNodeMock subfolderJson $ \da -> do + nodes <- listFolder da (DriveNodeId "FOLDER::com.apple.CloudDocs::D5AA0425") + all isFile nodes `shouldBe` True + + describe "downloadFile" $ do + it "returns LBS.empty when size is absent" $ + withNodeMock rootJson $ \da -> do + let fd = testFileData{fdSize = Nothing} + downloadFile da fd `shouldReturn` LBS.empty + it "returns LBS.empty when size is zero" $ + withNodeMock rootJson $ \da -> do + let fd = testFileData{fdSize = Just 0} + downloadFile da fd `shouldReturn` LBS.empty + it "downloads file contents" $ + withDownloadMock $ \da -> + downloadFile da testFileData `shouldReturn` "test file content" + + +-- Mock servers + +withNodeMock :: LBS.ByteString -> (DriveApi -> IO a) -> IO a +withNodeMock nodeJson action = + withSystemTempDirectory "icloud-drive-mock" $ \tmpDir -> + testWithApplication (pure (nodeApp nodeJson)) $ \serverPort -> do + da <- mkEpAndApi serverPort tmpDir + action da + + +withDownloadMock :: (DriveApi -> IO a) -> IO a +withDownloadMock action = + withSystemTempDirectory "icloud-drive-download" $ \tmpDir -> do + portRef <- newIORef 0 + testWithApplication (pure (downloadApp portRef)) $ \serverPort -> do + writeIORef portRef serverPort + da <- mkEpAndApi serverPort tmpDir + action da + + +nodeApp :: LBS.ByteString -> Application +nodeApp nodeJson req respond + | "/retrieveItemDetailsInFolders" `BS.isSuffixOf` rawPathInfo req = + respond $ responseLBS status200 jsonHeaders nodeJson + | otherwise = + respond $ responseLBS status404 [] "not found" + + +downloadApp :: IORef Int -> Application +downloadApp portRef req respond = do + serverPort <- readIORef portRef + let p = rawPathInfo req + if "/download/by_id" `BS.isSuffixOf` p + then + let url = "http://127.0.0.1:" ++ show serverPort ++ "/content/test" + body = LBS8.pack $ "{\"data_token\":{\"url\":\"" ++ url ++ "\",\"token\":\"tok\"}}" + in respond $ responseLBS status200 jsonHeaders body + else + if p == "/content/test" + then respond $ responseLBS status200 [] "test file content" + else respond $ responseLBS status404 [] "not found" + + +mkEpAndApi :: Int -> FilePath -> IO DriveApi +mkEpAndApi serverPort tmpDir = do + let baseUrl = Text.pack $ "http://127.0.0.1:" ++ show serverPort + mgr <- newManager defaultManagerSettings + api <- mkApiWith (testSession tmpDir) (testAuthEndpoints serverPort) mgr + mkDriveApi (testAccountData baseUrl) (testSession tmpDir) api + + +-- Fixtures + +testAccountData :: Text.Text -> AccountData +testAccountData baseUrl = + AccountData + { adHsaVersion = 2 + , adHsaChallengeRequired = False + , adHsaTrustedBrowser = Just True + , adWebservices = Map.fromList [("drivews", Webservice baseUrl Nothing), ("docws", Webservice baseUrl Nothing)] + , adRaw = object [] + } + + +testSession :: FilePath -> Session +testSession topDir = + Session + { sessionCreds = Credentials{credAccountName = "test@example.com", credPassword = "test-pass"} + , sessionTopDir = topDir + , sessionClientId = "auth-test-client-id" + } + + +testAuthEndpoints :: Int -> Endpoints +testAuthEndpoints serverPort = + Endpoints + { epHome = "http://127.0.0.1:" <> BS8.pack (show serverPort) + , epAuth = dummyReq "/appleauth/auth" + , epSetup = dummyReq "/setup/ws/1" + , epWidgetKey = "test-widget-key" + } + where + dummyReq reqPath = + defaultRequest + { host = "127.0.0.1" + , port = serverPort + , secure = False + , method = methodPost + , path = reqPath + } + + +testFileData :: FileData +testFileData = + FileData + { fdId = DriveNodeId "FILE::com.apple.CloudDocs::33A41112" + , fdDocId = "33A41112" + , fdEtag = "2k::2j" + , fdName = "Scan 2" + , fdExtension = Just "pdf" + , fdZone = "com.apple.CloudDocs" + , fdSize = Just 19876991 + , fdDateCreated = Nothing + , fdDateModified = Nothing + } + + +testFolderData :: FolderData +testFolderData = + FolderData + { fnId = DriveNodeId "FOLDER::com.apple.CloudDocs::DOCS" + , fnEtag = "1a" + , fnName = "Documents" + , fnZone = "com.apple.CloudDocs" + , fnDateCreated = Nothing + } + + +testNodes :: [DriveNode] +testNodes = [DriveFile testFileData, DriveFolder testFolderData] + + +isFile :: DriveNode -> Bool +isFile (DriveFile _) = True +isFile _ = False + + +jsonHeaders :: [(HeaderName, BS8.ByteString)] +jsonHeaders = [(hContentType, "application/json")] + + +rootJson :: LBS.ByteString +rootJson = + "[{\"drivewsid\":\"FOLDER::com.apple.CloudDocs::root\"\ + \,\"zone\":\"com.apple.CloudDocs\"\ + \,\"name\":\"\"\ + \,\"etag\":\"31\"\ + \,\"type\":\"FOLDER\"\ + \}]" + + +subfolderJson :: LBS.ByteString +subfolderJson = + "[{\"drivewsid\":\"FOLDER::com.apple.CloudDocs::D5AA0425-E84F-4501-AF5D-60F1D92648CF\"\ + \,\"zone\":\"com.apple.CloudDocs\"\ + \,\"name\":\"Test\"\ + \,\"etag\":\"2z\"\ + \,\"type\":\"FOLDER\"\ + \,\"items\":[\ + \{\"drivewsid\":\"FILE::com.apple.CloudDocs::33A41112-4131-4938-9691-7F356CE3C51D\"\ + \,\"docwsid\":\"33A41112-4131-4938-9691-7F356CE3C51D\"\ + \,\"zone\":\"com.apple.CloudDocs\"\ + \,\"name\":\"Scan 2\"\ + \,\"dateModified\":\"2020-04-27T21:37:36Z\"\ + \,\"size\":19876991\ + \,\"etag\":\"2k::2j\"\ + \,\"extension\":\"pdf\"\ + \,\"type\":\"FILE\"\ + \}\ + \,{\"drivewsid\":\"FILE::com.apple.CloudDocs::516C896C-6AA5-4A30-B30E-5502C2333DAE\"\ + \,\"docwsid\":\"516C896C-6AA5-4A30-B30E-5502C2333DAE\"\ + \,\"zone\":\"com.apple.CloudDocs\"\ + \,\"name\":\"Scanned document 1\"\ + \,\"dateModified\":\"2020-05-03T00:15:17Z\"\ + \,\"size\":21644358\ + \,\"etag\":\"32::2x\"\ + \,\"extension\":\"pdf\"\ + \,\"type\":\"FILE\"\ + \}\ + \]}]" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Module : Main +Copyright : (c) 2026 Tim Emiola +Maintainer : Tim Emiola +SPDX-License-Identifier: BSD-3-Clause + +Test suite entry point for hstratus-drive. +-} +module Main where + +import qualified HStratus.Drive.EndpointsSpec as DriveEndpoints +import qualified HStratus.Drive.MutationSpec as DriveMutation +import qualified HStratus.Drive.NodeSpec as DriveNode +import qualified HStratus.Drive.UploadSpec as DriveUpload +import qualified HStratus.DriveSpec as Drive +import System.IO + ( BufferMode (..) + , hSetBuffering + , stderr + , stdout + ) +import Test.Hspec + + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + hSetBuffering stderr NoBuffering + hspec $ do + DriveNode.spec + DriveEndpoints.spec + Drive.spec + DriveMutation.spec + DriveUpload.spec