hstratus-drive (empty) → 0.1.0.0
raw patch · 17 files changed
+2124/−0 lines, 17 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, case-insensitive, containers, hspec, hstratus-auth, hstratus-drive, http-client, http-types, temporary, text, time, vector, wai, warp
Files
- ChangeLog.md +9/−0
- LICENSE +30/−0
- README.md +72/−0
- Setup.hs +4/−0
- hstratus-drive.cabal +103/−0
- src-internal/Network/HStratus/Internal/Drive/Download.hs +278/−0
- src-internal/Network/HStratus/Internal/Drive/Endpoints.hs +192/−0
- src-internal/Network/HStratus/Internal/Drive/Node.hs +143/−0
- src-internal/Network/HStratus/Internal/Drive/NodeData.hs +165/−0
- src/Network/HStratus/Drive.hs +128/−0
- src/Network/HStratus/Drive/Node.hs +46/−0
- test/HStratus/Drive/EndpointsSpec.hs +96/−0
- test/HStratus/Drive/MutationSpec.hs +184/−0
- test/HStratus/Drive/NodeSpec.hs +194/−0
- test/HStratus/Drive/UploadSpec.hs +183/−0
- test/HStratus/DriveSpec.hs +259/−0
- test/Spec.hs +38/−0
+ ChangeLog.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+++main = defaultMain
+ hstratus-drive.cabal view
@@ -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 <adetokunbo@emio.la>+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
+ src-internal/Network/HStratus/Internal/Drive/Download.hs view
@@ -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 <adetokunbo@emio.la>+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)
+ src-internal/Network/HStratus/Internal/Drive/Endpoints.hs view
@@ -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 <adetokunbo@emio.la>+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)}
+ src-internal/Network/HStratus/Internal/Drive/Node.hs view
@@ -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 <adetokunbo@emio.la>+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)
+ src-internal/Network/HStratus/Internal/Drive/NodeData.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK prune #-}++{- |+Module : Network.HStratus.Internal.Drive.NodeData+Copyright : (c) 2026 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+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
+ src/Network/HStratus/Drive.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE NamedFieldPuns #-}++{- |+Module : Network.HStratus.Drive+Copyright : (c) 2025 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+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
+ src/Network/HStratus/Drive/Node.hs view
@@ -0,0 +1,46 @@+{- |+Module : Network.HStratus.Drive.Node+Copyright : (c) 2025 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+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+ )+
+ test/HStratus/Drive/EndpointsSpec.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : HStratus.Drive.EndpointsSpec+Copyright : (c) 2026 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+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/<zone>/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+ }
+ test/HStratus/Drive/MutationSpec.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : HStratus.Drive.MutationSpec+Copyright : (c) 2026 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+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")]
+ test/HStratus/Drive/NodeSpec.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : HStratus.Drive.NodeSpec+Copyright : (c) 2026 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+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
+ test/HStratus/Drive/UploadSpec.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : HStratus.Drive.UploadSpec+Copyright : (c) 2026 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+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")]
+ test/HStratus/DriveSpec.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : HStratus.DriveSpec+Copyright : (c) 2026 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+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\"\+ \}\+ \]}]"
+ test/Spec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : Main+Copyright : (c) 2026 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+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