syncthing-hs 0.1.0.0 → 0.1.1.0

raw patch · 17 files changed

+882/−78 lines, 17 filesdep +syncthing-hsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: syncthing-hs

API changes (from Hackage documentation)

Files

• Network/Syncthing.hs +10/−37
• Network/Syncthing/Get.hs +1/−1
• Network/Syncthing/Internal.hs +6/−0
• Network/Syncthing/Internal/Types.hs +26/−0
• Network/Syncthing/Post.hs +1/−1
• Network/Syncthing/Types.hs +44/−19
• Network/Syncthing/Types/Common.hs +0/−5
• Network/Syncthing/Utils.hs +18/−0
• README.md +1/−0
• changelog.md +10/−0
• syncthing-hs.cabal +17/−15
• tests/Properties/ErrorProperties.hs +51/−0
• tests/Properties/JsonArbitrary.hs +149/−0
• tests/Properties/JsonInstances.hs +158/−0
• tests/Properties/JsonProperties.hs +52/−0
• tests/UnitTests/Errors.hs +53/−0
• tests/UnitTests/Requests.hs +285/−0

@@ -48,17 +48,8 @@  module Network.Syncthing     (-    -- * Types-      Server-    , Device-    , FolderName-    , Path-    , Host-    , Port-    , Addr-     -- * The Syncthing Monad-    , SyncResult+      SyncResult     , SyncM     , syncthing @@ -88,33 +79,11 @@     , DeviceError(..)     , SyncError(..) -    -- * Data Types-    , CacheEntry(..)-    , Config(..)-    , AddressType(..)-    , FolderConfig(..)-    , DeviceConfig(..)-    , VersioningConfig(..)-    , GuiConfig(..)-    , OptionsConfig(..)-    , Connection(..)-    , DirTree(..)-    , Error(..)-    , Ignore(..)-    , Model(..)-    , ModelState(..)-    , Need(..)-    , Progress(..)-    , System(..)-    , SystemMsg(..)-    , Upgrade(..)-    , Version(..)-     -- * Utility functions-    , parseAddr -    , encodeAddr-    , toUTC-    , fromUTC+    , module Network.Syncthing.Utils++    -- * Types+    , module Network.Syncthing.Types      ) where  import           Control.Applicative              ((<$>))@@ -134,8 +103,8 @@ import           Network.Syncthing.Internal.Error import qualified Network.Syncthing.Internal.Lens  as PL import           Network.Syncthing.Internal.Monad-import           Network.Syncthing.Internal.Utils import           Network.Syncthing.Types+import           Network.Syncthing.Utils   -- | Use Wreq's getWith and postWith functions when running in IO@@ -223,6 +192,10 @@     , _pHttps    = False     , _pManager  = Left defaultManagerSettings     }++-- | The default folder name.+defaultFolder :: FolderName+defaultFolder = "default"  defaultResponseTimeout :: Int defaultResponseTimeout = 300000000 

@@ -44,7 +44,7 @@ import           Network.Syncthing.Internal.Error import           Network.Syncthing.Internal.Monad import           Network.Syncthing.Internal.Request-import           Network.Syncthing.Types+import           Network.Syncthing.Internal.Types   -- | Ping the Syncthing server. Returns the string \"pong\".

@@ -12,6 +12,10 @@     , module Network.Syncthing.Internal.Request     -- * Error Handling     , module Network.Syncthing.Internal.Error+    -- * Utils+    , module Network.Syncthing.Internal.Utils++    , module Network.Syncthing.Internal.Types     ) where  @@ -20,4 +24,6 @@ import           Network.Syncthing.Internal.Monad   hiding (liftEither,                                                      liftInner, liftReader) import           Network.Syncthing.Internal.Request+import           Network.Syncthing.Internal.Types+import           Network.Syncthing.Internal.Utils 

@@ -0,0 +1,26 @@++{-# OPTIONS_HADDOCK hide #-}++module Network.Syncthing.Internal.Types+    ( module Ty +    ) where+++import           Network.Syncthing.Types.CacheEntry as Ty+import           Network.Syncthing.Types.Common     as Ty+import           Network.Syncthing.Types.Completion as Ty+import           Network.Syncthing.Types.Config     as Ty+import           Network.Syncthing.Types.Connection as Ty+import           Network.Syncthing.Types.DeviceId   as Ty+import           Network.Syncthing.Types.DirTree    as Ty+import           Network.Syncthing.Types.Error      as Ty+import           Network.Syncthing.Types.Ignore     as Ty+import           Network.Syncthing.Types.Model      as Ty+import           Network.Syncthing.Types.Need       as Ty+import           Network.Syncthing.Types.Ping       as Ty+import           Network.Syncthing.Types.Sync       as Ty+import           Network.Syncthing.Types.System     as Ty+import           Network.Syncthing.Types.SystemMsg  as Ty+import           Network.Syncthing.Types.Upgrade    as Ty+import           Network.Syncthing.Types.Version    as Ty+

@@ -39,7 +39,7 @@  import           Network.Syncthing.Internal.Monad import           Network.Syncthing.Internal.Request-import           Network.Syncthing.Types+import           Network.Syncthing.Internal.Types   maybeSystemMsg :: MonadSync m => SyncRequest -> SyncM m (Maybe SystemMsg)

@@ -1,24 +1,49 @@ ++-- |+-- Module      : Network.Syncthing.Types+-- Copyright   : (c) 2014 Jens Thomas+--+-- License     : BSD-style+-- Maintainer  : jetho@gmx.de+-- Stability   : experimental+-- Portability : GHC+--+-- Type synonyms and data types.+ module Network.Syncthing.Types-    ( module Ty+    (  +    -- * Type Synonyms+      Server+    , Device+    , FolderName+    , Path+    , Host+    , Port+    , Addr+ +    -- * Data Types+    , CacheEntry(..)+    , Config(..)+    , AddressType(..)+    , FolderConfig(..)+    , DeviceConfig(..)+    , VersioningConfig(..)+    , GuiConfig(..)+    , OptionsConfig(..)+    , Connection(..)+    , DirTree(..)+    , Error(..)+    , Ignore(..)+    , Model(..)+    , ModelState(..)+    , Need(..)+    , Progress(..)+    , System(..)+    , SystemMsg(..)+    , Upgrade(..)+    , Version(..)        ) where --import           Network.Syncthing.Types.CacheEntry as Ty-import           Network.Syncthing.Types.Common     as Ty-import           Network.Syncthing.Types.Completion as Ty-import           Network.Syncthing.Types.Config     as Ty-import           Network.Syncthing.Types.Connection as Ty-import           Network.Syncthing.Types.DeviceId   as Ty-import           Network.Syncthing.Types.DirTree    as Ty-import           Network.Syncthing.Types.Error      as Ty-import           Network.Syncthing.Types.Ignore     as Ty-import           Network.Syncthing.Types.Model      as Ty-import           Network.Syncthing.Types.Need       as Ty-import           Network.Syncthing.Types.Ping       as Ty-import           Network.Syncthing.Types.Sync       as Ty-import           Network.Syncthing.Types.System     as Ty-import           Network.Syncthing.Types.SystemMsg  as Ty-import           Network.Syncthing.Types.Upgrade    as Ty-import           Network.Syncthing.Types.Version    as Ty+import Network.Syncthing.Internal.Types 

@@ -10,7 +10,6 @@     , Host     , Port     , Addr-    , defaultFolder     ) where  import           Data.Text (Text)@@ -30,8 +29,4 @@ type Port       = Int  type Addr       = (Host, Maybe Port)---- | The default folder name.-defaultFolder :: FolderName-defaultFolder = "default" 

@@ -0,0 +1,18 @@++-- |+-- Module      : Network.Syncthing.Utils+-- Copyright   : (c) 2014 Jens Thomas+--+-- License     : BSD-style+-- Maintainer  : jetho@gmx.de+-- Stability   : experimental+-- Portability : GHC+--+-- Some useful utility functions.++module Network.Syncthing.Utils+    ( module Network.Syncthing.Internal.Utils+    ) where++import Network.Syncthing.Internal.Utils+

@@ -2,6 +2,7 @@ syncthing-hs  ============ +[![Hackage](https://img.shields.io/hackage/v/syncthing-hs.svg)](https://hackage.haskell.org/package/syncthing-hs) [![Build Status](https://travis-ci.org/jetho/syncthing-hs.svg?branch=master)](https://travis-ci.org/jetho/syncthing-hs)  Haskell bindings for the [Syncthing REST API](https://github.com/syncthing/syncthing/wiki/REST-Interface).

@@ -0,0 +1,10 @@+0.1.1.0+-------+* Add test-suite source files+* Add module Network.Syncthing.Types+* Add module Network.Syncthing.Utils++0.1.0.0+-------+* Initial release.+

@@ -1,5 +1,5 @@ name:                syncthing-hs-version:             0.1.0.0+version:             0.1.1.0 synopsis:            Haskell bindings for the Syncthing REST API description:              .@@ -16,7 +16,7 @@ -- copyright:            category:            Network build-type:          Simple-extra-source-files:  README.md+extra-source-files:  README.md changelog.md cabal-version:       >=1.10  library@@ -26,13 +26,15 @@                      Network.Syncthing.Get                      Network.Syncthing.Post                      Network.Syncthing.Internal+                     Network.Syncthing.Types+                     Network.Syncthing.Utils   other-modules:     Network.Syncthing.Internal.Config                      Network.Syncthing.Internal.Error                      Network.Syncthing.Internal.Monad                      Network.Syncthing.Internal.Request                      Network.Syncthing.Internal.Lens+                     Network.Syncthing.Internal.Types                      Network.Syncthing.Internal.Utils-                     Network.Syncthing.Types                      Network.Syncthing.Types.CacheEntry                      Network.Syncthing.Types.Common                      Network.Syncthing.Types.Completion@@ -76,25 +78,25 @@   build-depends:       aeson >=0.8.0.1                      , base >=4.5 && <5                      , bytestring >=0.9-                     , connection >= 0.2.3                      , containers >= 0.5.5.1+                     , derive                        , either >=4.3.1-                     , http-client >=0.3.1.1-                     , http-client-tls >=0.2                      , lens >=4.5 -                     , old-locale >= 1.0.0.6-                     , regex-posix >= 0.95.2-                     , text >=1.2.0.0-                     , time >= 1.4.2-                     , transformers >=0.3.0.0-                     , unordered-containers >= 0.2.5.1-                     , wreq >=0.3.0.0-  build-depends:       derive                      , quickcheck-instances+                     , syncthing-hs                      , tasty                      , tasty-hunit                      , tasty-quickcheck-  hs-source-dirs:    tests, .+                     , text >=1.2.0.0+                     , transformers >=0.3.0.0+                     , wreq >=0.3.0.0+  other-modules:     Properties.ErrorProperties+                     Properties.JsonArbitrary+                     Properties.JsonInstances+                     Properties.JsonProperties+                     UnitTests.Errors+                     UnitTests.Requests+  hs-source-dirs:    tests   default-language:  Haskell2010  source-repository head

@@ -0,0 +1,51 @@++{-# LANGUAGE OverloadedStrings  #-}++module Properties.ErrorProperties+    ( errorProps+    ) where++import           Control.Applicative              ((<$>))+import           Control.Monad                    (ap)+import qualified Data.ByteString.Lazy.Char8       as BS+import           Data.Char                        (chr)+import qualified Data.Text                        as T+import           Test.Tasty+import           Test.Tasty.QuickCheck++import           Network.Syncthing.Internal+++newtype FolderErrText = FolderErrText { getFolderErrText :: BS.ByteString }+                        deriving (Eq, Show)++printableString :: Gen String+printableString = listOf1 . elements $ map chr [32 .. 126]++instance Arbitrary FolderErrText where+    arbitrary = FolderErrText . BS.pack . wrapText <$> printableString+      where wrapText t = "Folder " ++ t ++ " does not exist"++instance Arbitrary DeviceError where+    arbitrary = OtherDeviceError . T.pack <$> otherErrText+      where +        otherErrText  = printableString `suchThat` flip notElem reservedMsgs+        reservedMsgs  = [ "device ID invalid: incorrect length"+                        , "check digit incorrect"+                        ]++encodeDeviceError :: DeviceError -> T.Text+encodeDeviceError (OtherDeviceError errMsg) = errMsg++prop_folderErr :: FolderErrText -> Bool+prop_folderErr = (Just NoSuchFolder ==) . decodeError . getFolderErrText++prop_deviceErr :: DeviceError -> Bool+prop_deviceErr = ap (==) (decodeDeviceError . encodeDeviceError)++errorProps :: TestTree+errorProps = testGroup "Decoding Errors"+    [ testProperty "NoSuchFolder"(prop_folderErr :: FolderErrText -> Bool)+    , testProperty "DeviceError" (prop_deviceErr :: DeviceError -> Bool)+    ]+

@@ -0,0 +1,149 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+++module Properties.JsonArbitrary where++import           Control.Applicative              (pure, (<$>), (<*>))+import           Data.Char                        (isSpace)+import           Data.Derive.Arbitrary+import           Data.DeriveTH+import qualified Data.Map                         as M+import qualified Data.Text                        as T+import           Test.QuickCheck.Instances+import           Test.Tasty.QuickCheck++import           Network.Syncthing.Internal+++newtype NonEmptyText = NonEmptyText {getNonEmptyText :: T.Text}+                       deriving (Eq, Ord, Show, Read)++instance Arbitrary NonEmptyText where+    arbitrary = NonEmptyText . T.pack <$> listOf1 notSpace+      where notSpace = arbitrary `suchThat` (not . isSpace)+    shrink =   map NonEmptyText+             . filter (not . T.all isSpace)+             . shrink+             . getNonEmptyText++genAddr :: Gen Addr+genAddr = (,) <$> host <*> port+  where+    host      = T.pack <$> listOf1 hostChars+    hostChars = elements $ concat [['a'..'z'], ['A'.. 'Z'], ['0'..'9'], "."]+    port      = fmap getNonNegative <$> arbitrary++instance Arbitrary CacheEntry where+    arbitrary = CacheEntry <$> genAddr <*> arbitrary++instance Arbitrary Connection where+    arbitrary = Connection <$> arbitrary+                           <*> arbitrary+                           <*> arbitrary+                           <*> genAddr+                           <*> arbitrary++instance Arbitrary SystemMsg where+    arbitrary = oneof $ otherSystemMsg : knownMessages+      where+        knownMessages  = map pure [Restarting, ShuttingDown, ResettingFolders]+        otherSystemMsg = OtherSystemMsg <$> notReservedMsg+        notReservedMsg = arbitrary `suchThat` flip notElem reservedMsgs+        reservedMsgs   = ["restarting", "shutting down", "resetting folders"]++instance Arbitrary Model where+    arbitrary =+        Model <$> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> (fmap getNonEmptyText <$> arbitrary)+              <*> arbitrary++instance Arbitrary GuiConfig where+    arbitrary =+        GuiConfig <$> arbitrary+                  <*> (fmap getNonEmptyText <$> arbitrary)+                  <*> genAddr+                  <*> arbitrary+                  <*> arbitrary+                  <*> arbitrary++instance Arbitrary DeviceConfig where+    arbitrary =+        DeviceConfig <$> arbitrary+                     <*> arbitrary+                     <*> (listOf $ oneof [pure Dynamic, Address <$> genAddr])+                     <*> arbitrary+                     <*> arbitrary+                     <*> arbitrary++instance Arbitrary OptionsConfig where+    arbitrary =+        OptionsConfig <$> (listOf genAddr)+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary+                      <*> arbitrary++instance Arbitrary DirTree where+    arbitrary = choose (0, 5) >>= dirTree+      where+        genFile = File <$> arbitrary <*> arbitrary++        dirTree :: Int -> Gen DirTree+        dirTree 0       = genFile+        dirTree n | n>0 = frequency [(2, genFile), (1, Dir <$> dirContents)]+          where+            dirContents = M.fromList <$> listOf dirEntry+            dirEntry    = (,) <$> entryName <*> dirTree (n `div` 2)+            entryName   = getNonEmptyText <$> arbitrary+++-- | Let Template Haskell derive trivial instances.+concat <$> mapM (derive makeArbitrary)+                [ ''AddressType+                , ''FolderConfig+                , ''VersioningConfig+                , ''Config+                , ''Version+                , ''Ping+                , ''Completion+                , ''ModelState+                , ''Upgrade+                , ''Ignore+                , ''Progress+                , ''Need+                , ''Sync+                , ''DeviceError+                , ''Error+                , ''Errors+                , ''System+                ]+

@@ -0,0 +1,158 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE FlexibleInstances #-}+++module Properties.JsonInstances where++import           Control.Applicative              ((<$>), pure)+import           Data.Aeson                       hiding (Error)+import           Data.Maybe                       (fromMaybe)+import qualified Data.Text                        as T++import           Network.Syncthing.Internal+++singleField :: ToJSON a => T.Text -> a -> Value+singleField fieldName = object . pure . (fieldName .=)++encodeMaybe = fromMaybe ""++encodeUTC = encodeMaybe . fmap fromUTC ++encodeInvalid = encodeMaybe . fmap T.unpack ++encodeModelState = encodeMaybe . fmap encodeState+  where encodeState state = +            case state of+                Idle     -> "idle"+                Scanning -> "scanning"+                Cleaning -> "cleaning"+                Syncing  -> "syncing"++instance ToJSON Version where+    toJSON Version{..} =+        object [ "arch"         .= getArch+               , "longVersion"  .= getLongVersion+               , "os"           .= getOs+               , "version"      .= getVersion+               ]++instance ToJSON Ping where+    toJSON = singleField "ping" . getPing++instance ToJSON Completion where+    toJSON = singleField "completion" . getCompletion ++instance ToJSON Sync where+    toJSON = singleField "configInSync" . getSync ++instance ToJSON CacheEntry where+    toJSON CacheEntry{..} =+        object [ "Address"  .= encodeAddr getAddr+               , "Seen"     .= encodeUTC getSeen+               ]++instance ToJSON Connection where+    toJSON Connection{..} =+        object [ "At"            .= encodeUTC getAt+               , "InBytesTotal"  .= getInBytesTotal+               , "OutBytesTotal" .= getOutBytesTotal+               , "Address"       .= encodeAddr getAddress+               , "ClientVersion" .= getClientVersion+               ]++instance ToJSON Model where+    toJSON Model{..} =+        object [ "globalBytes"   .= getGlobalBytes   +               , "globalDeleted" .= getGlobalDeleted +               , "globalFiles"   .= getGlobalFiles   +               , "inSyncBytes"   .= getInSyncBytes   +               , "inSyncFiles"   .= getInSyncFiles   +               , "localBytes"    .= getLocalBytes    +               , "localDeleted"  .= getLocalDeleted  +               , "localFiles"    .= getLocalFiles    +               , "needBytes"     .= getNeedBytes     +               , "needFiles"     .= getNeedFiles     +               , "state"         .= encodeModelState getState         +               , "stateChanged"  .= encodeUTC getStateChanged  +               , "invalid"       .= encodeInvalid getInvalid+               , "version"       .= getModelVersion  +               ]++instance ToJSON Upgrade where+    toJSON Upgrade{..} =+        object [ "latest"  .= getLatest+               , "newer"   .= getNewer+               , "running" .= getRunning+               ]++instance ToJSON Ignore where+    toJSON Ignore{..} =+        object [ "ignore"   .= getIgnores+               , "patterns" .= getPatterns+               ]++instance ToJSON Need where+    toJSON Need{..} =+        object [ "progress" .= getProgress+               , "queued"   .= getQueued+               , "rest"     .= getRest+               ]++instance ToJSON Progress where+    toJSON Progress{..} =+        object [ "Name"         .= getName            +               , "Flags"        .= getFlags           +               , "Modified"     .= getModified        +               , "Version"      .= getProgressVersion +               , "LocalVersion" .= getLocalVersion    +               , "NumBlocks"    .= getNumBlocks       +               , "Size"         .= getSize            +               ]++instance ToJSON System where+    toJSON System{..} =+        object [ "alloc"            .= getAlloc            +               , "cpuPercent"       .= getCpuPercent           +               , "extAnnounceOK"    .= getExtAnnounceOK        +               , "goroutines"       .= getGoRoutines +               , "myID"             .= getMyId    +               , "sys"              .= getSys       +               ]++instance ToJSON (Either DeviceError Device) where+    toJSON = object . pure . either deviceError deviceId +      where deviceError = ("error" .=) . encodeDeviceError +            deviceId    = ("id" .=) ++encodeDeviceError :: DeviceError -> T.Text+encodeDeviceError err = +    case err of+        IncorrectLength     -> "device ID invalid: incorrect length"+        IncorrectCheckDigit -> "check digit incorrect"+        OtherDeviceError e  -> e++instance ToJSON SystemMsg where+    toJSON msg = object [ "ok" .= decodedSystemMsg ]+      where +        decodedSystemMsg = case msg of+            Restarting       -> "restarting"+            ShuttingDown     -> "shutting down"+            ResettingFolders -> "resetting folders"+            OtherSystemMsg m -> m++instance ToJSON Error where+    toJSON Error{..} =+        object [ "Time"  .= encodeUTC getTime+               , "Error" .= getMsg+               ]++instance ToJSON Errors where+    toJSON = singleField "errors" . getErrors ++instance ToJSON DirTree where+    toJSON Dir{..}  = toJSON getDirContents+    toJSON File{..} = toJSON [getModTime, getFileSize] +

@@ -0,0 +1,52 @@++module Properties.JsonProperties+    ( jsonProps+    ) where++import           Data.Aeson                       +import           Test.Tasty+import           Test.Tasty.QuickCheck++import           Network.Syncthing.Internal++import           Properties.JsonArbitrary+import           Properties.JsonInstances+++type EitherDeviceErrorId = Either DeviceError Device+++genProp name prop = testProperty testName prop+  where+    testName = name ++ " == decode . encode"++prop_json :: (Eq a, FromJSON a, ToJSON a) => a -> Bool+prop_json x = Just x == (decode . encode $ x)++jsonProps :: TestTree+jsonProps = testGroup "JSON Parsers"+    [ genProp "Ping"             (prop_json :: Ping -> Bool)+    , genProp "Version"          (prop_json :: Version -> Bool)+    , genProp "Completion"       (prop_json :: Completion -> Bool)+    , genProp "CacheEntry"       (prop_json :: CacheEntry -> Bool)+    , genProp "Connection"       (prop_json :: Connection -> Bool)+    , genProp "Model"            (prop_json :: Model -> Bool)+    , genProp "Upgrade"          (prop_json :: Upgrade -> Bool)+    , genProp "Ignore"           (prop_json :: Ignore -> Bool)+    , genProp "Progress"         (prop_json :: Progress -> Bool)+    , genProp "Need"             (prop_json :: Need -> Bool)+    , genProp "Sync"             (prop_json :: Sync -> Bool)+    , genProp "DeviceId"         (prop_json :: EitherDeviceErrorId -> Bool)+    , genProp "SystemMsg"        (prop_json :: SystemMsg -> Bool)+    , genProp "VersioningConfig" (prop_json :: VersioningConfig -> Bool)+    , genProp "FolderConfig"     (prop_json :: FolderConfig -> Bool)+    , genProp "GuiConfig"        (prop_json :: GuiConfig -> Bool)+    , genProp "OptionsConfig"    (prop_json :: OptionsConfig -> Bool)+    , genProp "DeviceConfig"     (prop_json :: DeviceConfig -> Bool)+    , genProp "Config"           (prop_json :: Config -> Bool)+    , genProp "Error"            (prop_json :: Error -> Bool)+    , genProp "Errors"           (prop_json :: Errors -> Bool)+    , genProp "System"           (prop_json :: System -> Bool)+    , genProp "DirTree"          (prop_json :: DirTree -> Bool)+    ]+

@@ -0,0 +1,53 @@++{-# LANGUAGE OverloadedStrings #-}++module UnitTests.Errors+    ( errorUnits+    ) where++import qualified Data.ByteString.Lazy.Char8 as BS+import qualified Data.Text                  as T+import           Test.Tasty+import           Test.Tasty.HUnit++import           Network.Syncthing.Internal+++createTestName :: Show err => err -> String+createTestName = ("Decode " ++) . show++createDescription :: Show err => err -> String -> String+createDescription errType errMsg =+    concat [show errMsg, " decodes to ", show errType]++testDecodeError :: SyncError -> BS.ByteString -> TestTree+testDecodeError errType errMsg =+    testCase (createTestName errType) $+        assertEqual (createDescription errType $ BS.unpack errMsg)+                    (Just errType)+                    (decodeError errMsg)++testDecodeDeviceError :: DeviceError -> T.Text -> TestTree+testDecodeDeviceError errType errMsg =+    testCase (createTestName errType) $+        assertEqual (createDescription errType $ T.unpack errMsg)+                    errType+                    (decodeDeviceError errMsg)+++errorUnits :: TestTree+errorUnits = testGroup "Unit Tests for error messages" $+    map (uncurry testDecodeError)+    [ (CSRFError, "CSRF Error")+    , (NotAuthorized, "Not Authorized")+    , (NotFound, "404 page not found")+    , (NoSuchFolder, "no such folder")+    , ((InvalidDeviceId IncorrectLength), "device ID invalid: incorrect length")+    , ((InvalidDeviceId IncorrectCheckDigit), "check digit incorrect")+    ]+    +++    map (uncurry testDecodeDeviceError)+    [ (IncorrectLength, "device ID invalid: incorrect length")+    , (IncorrectCheckDigit, "check digit incorrect")+    ]+

@@ -0,0 +1,285 @@++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module UnitTests.Requests+    ( requestUnits+    ) where++import           Control.Applicative        ((<$>))+import           Control.Lens               ((&), (.~), (?~), (^.))+import           Control.Monad.Trans.Either (runEitherT)+import           Control.Monad.Trans.Reader (runReaderT)+import           Control.Monad.Trans.Writer (Writer, execWriter, tell)+import           Data.Aeson                 (ToJSON, Value, toJSON)+import           Data.List                  (isPrefixOf, sort)+import qualified Data.Map                   as M+import qualified Data.Text                  as T+import           Data.Text.Encoding         (encodeUtf8)+import qualified Network.Wreq               as W+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.QuickCheck++import           Network.Syncthing+import qualified Network.Syncthing.Get      as Get+import           Network.Syncthing.Internal+import qualified Network.Syncthing.Post     as Post++import           Properties.JsonArbitrary+import           Properties.JsonInstances++++-------------- Test Infrastructure --------------++type Endpoint = String+type Url      = String+type Params   = [Param]++data RequestType = GET | POST+                 deriving (Eq, Show)++data LoggedRequest = LoggedRequest {+      reqType    :: RequestType+    , reqUrl     :: String+    , reqOptions :: W.Options+    , reqPayload :: Maybe Value+    }++type RequestLogger  = Writer [LoggedRequest]+type LogAction      = SyncM RequestLogger+type LogResult a    = RequestLogger (SyncResult a)++instance MonadSync RequestLogger where+    getMethod  o s   = tell [ LoggedRequest GET  s o Nothing  ] >> return ""+    postMethod o s p = tell [ LoggedRequest POST s o (Just p) ] >> return ""++mockedSyncthing :: SyncConfig -> LogAction a -> LogResult a+mockedSyncthing config action =+    flip runReaderT config $ runEitherT $ runSyncthing action++extractRequest :: LogResult a -> LoggedRequest+extractRequest = head . execWriter++execRequest :: SyncConfig -> LogAction a -> LoggedRequest+execRequest cfg action = extractRequest $ mockedSyncthing cfg action++withConfigRequest :: SyncConfig -> LogAction a -> (LoggedRequest -> b) -> b+withConfigRequest cfg action f = f $ execRequest cfg action++withRequest :: LogAction a -> (LoggedRequest -> b) -> b+withRequest = withConfigRequest defaultConfig++++-------------- Helper Functions --------------++noPayload :: ()+noPayload = ()++noParams :: Params+noParams = []++createIgnoresMap :: [T.Text] -> M.Map T.Text [T.Text] +createIgnoresMap = M.singleton "ignore" ++serverString :: SyncConfig -> String+serverString = T.unpack . (^. pServer)++assertReqType :: RequestType -> RequestType -> Assertion+assertReqType rType reqType =+    assertEqual (show rType ++ " Request is executed") rType reqType ++assertUrl :: SyncConfig -> Endpoint -> Url -> Assertion+assertUrl cfg endpoint reqUrl =+    let url = "http://" ++ serverString cfg ++ endpoint+    in  assertEqual "Request url is correct" url reqUrl++assertParams :: Params -> W.Options -> Assertion+assertParams params reqOptions =+    let reqParams = reqOptions ^. W.params+    in  assertEqual "Params set correctly" (sort params) (sort reqParams)++assertPayload :: ToJSON p => p -> Maybe Value -> Assertion +assertPayload payload reqPayload =+    let payload' = Just . toJSON $ payload+    in  assertEqual "Payload injected correctly" payload' reqPayload++assertGet :: LoggedRequest -> Endpoint -> Params -> Assertion+assertGet LoggedRequest{..} endpoint params = do+    assertReqType GET reqType+    assertUrl defaultConfig endpoint reqUrl+    assertParams params reqOptions++assertPost :: ToJSON p => LoggedRequest -> Endpoint -> Params -> p -> Assertion+assertPost LoggedRequest{..} endpoint params payload = do+    assertReqType POST reqType+    assertUrl defaultConfig endpoint reqUrl+    assertParams params reqOptions+    assertPayload payload reqPayload++++-------------- Basic Tests --------------++basicRequest rType endpoint action  = withRequest action $+    \LoggedRequest{..} -> do+        assertReqType rType reqType +        assertUrl defaultConfig endpoint reqUrl+        assertEqual "Accept header contains 'application/json'"+            ["application/json"] (reqOptions ^. W.header "Accept")++changeServer =+    let server = "192.168.0.10:8080"+        cfg    = defaultConfig & pServer .~ server+    in+    withConfigRequest cfg Get.ping $+        \LoggedRequest{..} -> assertUrl cfg "/rest/ping" reqUrl++setApiKey =+    let apiKey = "123456789XYZ"+        cfg    = defaultConfig & pApiKey ?~ apiKey+    in+    withConfigRequest cfg Get.ping $+        \LoggedRequest{..} -> +            assertEqual "ApiKey is set as X-API-KEY header"+                [encodeUtf8 apiKey] (reqOptions ^. W.header "X-API-KEY")++enableAuth =+    let auth = W.basicAuth "user" "pass"+        cfg  = defaultConfig & pAuth ?~ auth+    in+    withConfigRequest cfg Get.ping $+        \LoggedRequest{..} -> +            assertEqual "Auth enabled" (Just auth) (reqOptions ^. W.auth)++enableHttps =+    let cfg = defaultConfig & pHttps .~ True+    in+    withConfigRequest cfg Get.ping $+        \LoggedRequest{..} -> +            assertBool "HTTPS protocol is used" $ "https://" `isPrefixOf` reqUrl++disableHttps =+    let cfg = defaultConfig & pHttps .~ False+    in+    withConfigRequest cfg Get.ping $+        \LoggedRequest{..} -> +            assertBool "HTTP protocol is used" $ "http://" `isPrefixOf` reqUrl++++-------------- GET and POST Requests --------------++testGet :: Endpoint -> Params -> LogAction a -> TestTree+testGet endpoint params action = withRequest action $+    \loggedRequest ->+        testCase ("Test GET " ++ endpoint) $ +            assertGet loggedRequest endpoint params            ++testPost :: ToJSON p => Endpoint -> Params -> p -> LogAction a -> TestTree+testPost endpoint params payload action = withRequest action $+    \loggedRequest ->+        testCase ("Test POST " ++ endpoint) $ +            assertPost loggedRequest endpoint params payload++-- | Post.sendConfig requires special treatment. Use Quickcheck to generate+-- sample data for the payload.+testPostConfig :: Endpoint -> Params -> TestTree+testPostConfig endpoint params = +    testCase ("Test POST " ++ endpoint) $ do+        configSample <- head <$> sample' (arbitrary :: Gen Config)+        withRequest (Post.sendConfig configSample) $ +            \loggedRequest -> +                assertPost loggedRequest endpoint params configSample++++-------------- Test Suite --------------++requestUnits :: TestTree+requestUnits = testGroup "Unit Tests for Requests" +    [ testGroup "Basic Tests"+        [ testCase "GET Request"  $ basicRequest GET  "/rest/ping" Get.ping+        , testCase "POST Request" $ basicRequest POST "/rest/ping" Post.ping+        , testCase "changeServer"           changeServer+        , testCase "set ApiKey"             setApiKey+        , testCase "enable Authentication"  enableAuth+        , testCase "enable HTTPS usage"     enableHttps+        , testCase "disable HTTPS usage"    disableHttps+        ]+    , testGroup "GET Requests"+        [ testGet "/rest/ping"          noParams Get.ping+        , testGet "/rest/completion"+                  [("folder","default"), ("device", "device1")] +                  (Get.completion "device1" "default")+        , testGet "/rest/config"        noParams Get.config+        , testGet "/rest/connections"   noParams Get.connections+        , testGet "/rest/deviceid" +                  [("id", "device1")] +                  (Get.deviceId "device1")+        , testGet "/rest/discovery"     noParams Get.discovery+        , testGet "/rest/errors"        noParams Get.errors+        , testGet "/rest/ignores" +                  [("folder", "default")] +                  (Get.ignores "default")+        , testGet "/rest/model" +                  [("folder", "default")] +                  (Get.model "default")+        , testGet "/rest/need"  +                  [("folder", "default")] +                  (Get.need "default")+        , testGet "/rest/config/sync"   noParams Get.sync+        , testGet "/rest/system"        noParams Get.system+        , testGet "/rest/tree"        +                  [("folder", "default")]+                  (Get.tree "default" Nothing Nothing)+        , testGet "/rest/tree"        +                  [("folder", "default"), ("prefix", "foo/bar")]+                  (Get.tree "default" (Just "foo/bar") Nothing)+        , testGet "/rest/tree"        +                  [("folder", "default"), ("levels", "2")]+                  (Get.tree "default" Nothing (Just 2))+        , testGet "/rest/tree"        +                  [("folder", "default"),("prefix", "foo/bar"),("levels", "2")]+                  (Get.tree "default" (Just "foo/bar") (Just 2))+        , testGet "/rest/upgrade"       noParams Get.upgrade+        , testGet "/rest/version"       noParams Get.version+        ]+    , testGroup "POST Requests"+        [ testPost "/rest/ping"         noParams noPayload Post.ping+        , testPost "/rest/bump"+                   [("folder", "default"), ("file", "foo/bar")] +                   noPayload+                   (Post.bump "default" "foo/bar")+        , testPost "/rest/discovery/hint"+                   [("device", "device1"), ("addr", "192.168.0.10:8080")] +                   noPayload+                   (Post.hint "device1" "192.168.0.10:8080")+        , testPost "/rest/error" +                   noParams +                   (T.pack "Error 1") +                   (Post.sendError "Error 1")+        , testPost "/rest/error/clear"  noParams noPayload Post.clearErrors+        , testPost "/rest/scan" +                   [("folder", "default")] +                   noPayload +                   (Post.scanFolder "default" Nothing)+        , testPost "/rest/scan"+                   [("folder", "default"), ("sub", "foo/bar")] +                   noPayload +                   (Post.scanFolder "default" (Just "foo/bar"))+        , testPost "/rest/restart"      noParams noPayload Post.restart+        , testPost "/rest/shutdown"     noParams noPayload Post.shutdown+        , testPost "/rest/reset"        noParams noPayload Post.reset+        , testPost "/rest/upgrade"      noParams noPayload Post.upgrade+        , testPost "/rest/ignores" +                   [("folder", "default")] +                   (createIgnoresMap ["file1", "file2", "foo/bar"])+                   (Post.sendIgnores "default" ["file1", "file2", "foo/bar"])+        , testPostConfig "/rest/config" noParams+        ]+    ]+