syncthing-hs (empty) → 0.1.0.0
raw patch · 34 files changed
+2120/−0 lines, 34 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, connection, containers, derive, either, http-client, http-client-tls, lens, old-locale, quickcheck-instances, regex-posix, tasty, tasty-hunit, tasty-quickcheck, text, time, transformers, unordered-containers, wreq
Files
- LICENSE +30/−0
- Network/Syncthing.hs +296/−0
- Network/Syncthing/Get.hs +149/−0
- Network/Syncthing/Internal.hs +23/−0
- Network/Syncthing/Internal/Config.hs +38/−0
- Network/Syncthing/Internal/Error.hs +68/−0
- Network/Syncthing/Internal/Lens.hs +16/−0
- Network/Syncthing/Internal/Monad.hs +54/−0
- Network/Syncthing/Internal/Request.hs +103/−0
- Network/Syncthing/Internal/Utils.hs +51/−0
- Network/Syncthing/Post.hs +123/−0
- Network/Syncthing/Session.hs +113/−0
- Network/Syncthing/Types.hs +24/−0
- Network/Syncthing/Types/CacheEntry.hs +29/−0
- Network/Syncthing/Types/Common.hs +37/−0
- Network/Syncthing/Types/Completion.hs +19/−0
- Network/Syncthing/Types/Config.hs +322/−0
- Network/Syncthing/Types/Connection.hs +35/−0
- Network/Syncthing/Types/DeviceId.hs +26/−0
- Network/Syncthing/Types/DirTree.hs +35/−0
- Network/Syncthing/Types/Error.hs +36/−0
- Network/Syncthing/Types/Ignore.hs +25/−0
- Network/Syncthing/Types/Model.hs +73/−0
- Network/Syncthing/Types/Need.hs +51/−0
- Network/Syncthing/Types/Ping.hs +19/−0
- Network/Syncthing/Types/Sync.hs +19/−0
- Network/Syncthing/Types/System.hs +36/−0
- Network/Syncthing/Types/SystemMsg.hs +35/−0
- Network/Syncthing/Types/Upgrade.hs +27/−0
- Network/Syncthing/Types/Version.hs +29/−0
- README.md +51/−0
- Setup.hs +2/−0
- syncthing-hs.cabal +103/−0
- tests/Test.hs +23/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Jens Thomas++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 Jens Thomas 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.
+ Network/Syncthing.hs view
@@ -0,0 +1,296 @@++{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Network.Syncthing+-- Copyright : (c) 2014 Jens Thomas+--+-- License : BSD-style+-- Maintainer : jetho@gmx.de+-- Stability : experimental+-- Portability : GHC+--+-- Haskell bindings for the Syncthing REST API.+--+-- The library is based on the "Network.Wreq" package and uses some of wreq\'s+-- functionalities for client configuration. For example, to use authentication,+-- you need to import the "Network.Wreq" module.+--+-- __/Example Usage:/__+--+-- @+-- \{\-\# LANGUAGE OverloadedStrings \#\-\}+--+-- import qualified "Network.Wreq" as Wreq+-- import "Control.Monad" ('Control.Monad.liftM2')+-- import "Control.Lens" (('Control.Lens.&'), ('Control.Lens..~'), ('Control.Lens.?~'))+-- import "Network.Syncthing"+-- import qualified "Network.Syncthing.Get" as Get +--+-- \-\- A single Syncthing request.+-- single = 'syncthing' 'defaultConfig' Get.'Network.Syncthing.Get.ping'+--+-- \-\- Connection sharing for multiple Syncthing requests.+-- multiple1 = 'withManager' $ \\cfg ->+-- 'syncthing' cfg $ do+-- p <- Get.'Network.Syncthing.Get.ping'+-- v <- Get.'Network.Syncthing.Get.version'+-- return (p, v)+--+-- \-\- Multiple Syncthing requests with connection sharing and customized configuration.+-- multiple2 = 'withManager' $ \\cfg -> do+-- let cfg\' = cfg 'Control.Lens.&' 'pServer' 'Control.Lens..~' \"192.168.0.10:8080\"+-- 'Control.Lens.&' 'pHttps' 'Control.Lens..~' True+-- 'Control.Lens.&' 'pAuth' 'Control.Lens.?~' Wreq.'Network.Wreq.basicAuth' \"user\" \"pass\"+-- 'syncthing' cfg\' $ 'Control.Monad.liftM2' (,) Get.'Network.Syncthing.Get.ping' Get.'Network.Syncthing.Get.version'+-- @++module Network.Syncthing+ (+ -- * Types+ Server+ , Device+ , FolderName+ , Path+ , Host+ , Port+ , Addr++ -- * The Syncthing Monad+ , SyncResult+ , SyncM+ , syncthing++ -- * Connection sharing+ , withManager+ , withManagerNoVerify+ , withManager'++ -- * Configuration+ , SyncConfig+ , pServer+ , pApiKey+ , pAuth+ , pHttps+ , pManager++ -- * Defaults+ , defaultConfig+ , defaultFolder++ -- * Manager Settings+ , defaultManagerSettings+ , noSSLVerifyManagerSettings+ , setResponseTimeout ++ -- * Error Handling+ , 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+ ) where++import Control.Applicative ((<$>))+import Control.Exception (catch, throwIO)+import Control.Lens (Lens', (&), (.~), (^.))+import Control.Monad ((<=<))+import Control.Monad.Trans.Either (runEitherT)+import Control.Monad.Trans.Reader (runReaderT)+import Data.ByteString.Lazy (fromStrict)+import Data.Text (Text)+import Network.Connection (TLSSettings (..))+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Client.TLS (mkManagerSettings, tlsManagerSettings)+import qualified Network.Wreq as W++import Network.Syncthing.Internal.Config+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+++-- | Use Wreq's getWith and postWith functions when running in IO+instance MonadSync IO where+ getMethod o s = (^. W.responseBody) <$> W.getWith o s+ postMethod o s p = (^. W.responseBody) <$> W.postWith o s p++-- | Create a default configuration with a new manager for connection+-- sharing. The manager is released after running the Syncthing actions(s).+-- This is equivalent to:+--+-- @+-- 'withManager'' 'defaultManagerSettings'+-- @+--+-- /Examples:/+--+-- @+-- 'withManager' $ \\cfg ->+-- 'syncthing' cfg $ 'Control.Monad.liftM2' (,) Get.'Network.Syncthing.Get.ping' Get.'Network.Syncthing.Get.version'+-- @+-- @+-- 'withManager' $ \\cfg -> do+-- let cfg\' = cfg 'Control.Lens.&' 'pServer' 'Control.Lens..~' \"192.168.0.10:8080\"+-- 'syncthing' cfg\' $ 'Control.Monad.liftM2' (,) Get.'Network.Syncthing.Get.ping' Get.'Network.Syncthing.Get.version'+-- @+withManager :: (SyncConfig -> IO a) -> IO a+withManager = withManager' defaultManagerSettings++-- | Create a manager with disabled SSL certificate verification. +-- This is equivalent to:+--+-- @+-- 'withManager'' 'noSSLVerifyManagerSettings'+-- @+--+-- /Example:/+--+-- @+-- 'withManagerNoVerify' $ \\cfg -> do+-- let cfg\' = cfg 'Control.Lens.&' 'pHttps' 'Control.Lens..~' True+-- 'syncthing' cfg\' $ 'Control.Monad.liftM2' (,) Get.'Network.Syncthing.Get.ping' Get.'Network.Syncthing.Get.version'+-- @+withManagerNoVerify :: (SyncConfig -> IO a) -> IO a+withManagerNoVerify = withManager' noSSLVerifyManagerSettings++-- | Create a manager by using the provided manager settings.+--+-- /Example:/+--+-- @+-- 'withManager'' 'noSSLVerifyManagerSettings' $ \\cfg -> do+-- let cfg\' = cfg 'Control.Lens.&' 'pHttps' 'Control.Lens..~' True+-- 'syncthing' cfg\' $ 'Control.Monad.liftM2' (,) Get.'Network.Syncthing.Get.ping' Get.'Network.Syncthing.Get.version'+-- @+withManager' :: HTTP.ManagerSettings -> (SyncConfig -> IO a) -> IO a+withManager' settings act =+ HTTP.withManager settings $ \mgr ->+ act $ defaultConfig & pManager .~ Right mgr++-- | Run Syncthing requests.+syncthing :: SyncConfig -> SyncM IO a -> IO (SyncResult a)+syncthing config action =+ runReaderT (runEitherT $ runSyncthing action) config `catch` handler+ where+ handler e@(HTTP.StatusCodeException _ headers _) =+ maybe (throwIO e) (return . Left) $ maybeSyncError headers+ handler unhandledErr = throwIO unhandledErr+ maybeSyncError = decodeError . fromStrict <=< lookup "X-Response-Body-Start"++-- | The default Syncthing configuration. Customize it to your needs by using+-- the SyncConfig lenses.+--+-- /Example:/+--+-- >>> defaultConfig+-- SyncConfig { pServer = "127.0.0.1:8080", pApiKey = Nothing, pAuth = Nothing, pHttps = False, pManager = Left _ }+-- >>> defaultConfig & pServer .~ "192.168.0.10:8080" & pApiKey ?~ "XXXX"+-- SyncConfig { pServer = "192.168.0.10:8080", pApiKey = Just "XXXX", pAuth = Nothing, pHttps = False, pManager = Left _ }+defaultConfig :: SyncConfig+defaultConfig = SyncConfig {+ _pServer = "127.0.0.1:8080"+ , _pApiKey = Nothing+ , _pAuth = Nothing+ , _pHttps = False+ , _pManager = Left defaultManagerSettings+ }++defaultResponseTimeout :: Int+defaultResponseTimeout = 300000000 ++-- | Set the response timeout (in microseconds). Default is 300 seconds.+setResponseTimeout :: HTTP.ManagerSettings -> Int -> HTTP.ManagerSettings+setResponseTimeout ms t = ms { HTTP.managerResponseTimeout = Just t }++-- | The default manager settings used by 'defaultConfig'.+defaultManagerSettings :: HTTP.ManagerSettings+defaultManagerSettings = + tlsManagerSettings `setResponseTimeout` defaultResponseTimeout ++-- | Alternative manager settings with disabled SSL certificate verification.+noSSLVerifyManagerSettings :: HTTP.ManagerSettings+noSSLVerifyManagerSettings = ms `setResponseTimeout` defaultResponseTimeout + where ms = mkManagerSettings (TLSSettingsSimple True False False) Nothing++-- | A lens for configuring the server address. Use the ADDRESS:PORT format.+--+-- /Example:/+--+-- @+-- let cfg = 'defaultConfig' 'Control.Lens.&' 'pApiKey' 'Control.Lens..~' \"192.168.0.10:8080\"+-- 'syncthing' cfg Get.'Network.Syncthing.Get.ping'+-- @+pServer :: Lens' SyncConfig Server+pServer = PL.pServer++-- | A lens for specifying the Syncthing API Key.+--+-- /Example:/+--+-- @+-- let cfg = 'defaultConfig' 'Control.Lens.&' 'pApiKey' 'Control.Lens.?~' \"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXX\"+-- 'syncthing' cfg Get.'Network.Syncthing.Get.ping'+-- @+pApiKey :: Lens' SyncConfig (Maybe Text)+pApiKey = PL.pApiKey++-- | A lens for configuring request authentication provided by the +-- 'Network.Wreq' package (see 'Network.Wreq.Auth').+--+-- /Example:/+--+-- @+-- import qualified "Network.Wreq" as Wreq+--+-- let cfg = 'defaultConfig' 'Control.Lens.&' 'pHttps' 'Control.Lens..~' True+-- 'Control.Lens.&' 'pAuth' 'Control.Lens.?~' Wreq.'Network.Wreq.basicAuth' \"user\" \"pass\"+-- 'syncthing' cfg Get.'Network.Syncthing.Get.ping'+-- @+pAuth :: Lens' SyncConfig (Maybe W.Auth)+pAuth = PL.pAuth++-- | A lens for enabling HTTPS usage.+--+-- /Example:/+--+-- @+-- let cfg = 'defaultConfig' 'Control.Lens.&' 'pHttps' 'Control.Lens..~' True+-- 'syncthing' cfg Get.'Network.Syncthing.Get.ping'+-- @+pHttps :: Lens' SyncConfig Bool+pHttps = PL.pHttps++-- | A lens for specifying your own ManagerSettings/Manager. For more+-- information, please refer to the "Network.HTTP.Client" package.+pManager :: Lens' SyncConfig (Either HTTP.ManagerSettings HTTP.Manager)+pManager = PL.pManager+
+ Network/Syncthing/Get.hs view
@@ -0,0 +1,149 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module : Network.Syncthing.Get+-- Copyright : (c) 2014 Jens Thomas+--+-- License : BSD-style+-- Maintainer : jetho@gmx.de+-- Stability : experimental+-- Portability : GHC+--+-- Syncthing GET requests.++module Network.Syncthing.Get+ (+ -- * Request functions+ ping+ , apiKey+ , config+ , completion+ , connections+ , deviceId+ , discovery+ , errors+ , ignores+ , model+ , need+ , sync+ , system+ , tree+ , upgrade+ , version+ ) where++import Control.Applicative ((<$>))+import Control.Monad ((>=>))+import qualified Data.Map as M+import Data.Maybe (catMaybes)+import Data.Text (Text, pack)++import Network.Syncthing.Internal.Error+import Network.Syncthing.Internal.Monad+import Network.Syncthing.Internal.Request+import Network.Syncthing.Types+++-- | Ping the Syncthing server. Returns the string \"pong\".+ping :: MonadSync m => SyncM m Text+ping = getPing <$> ping'+ where+ ping' = query $ getRequest { path = "/rest/ping" }++-- | Return the current configuration.+config :: MonadSync m => SyncM m Config+config = query $ getRequest { path = "/rest/config" }++-- | Get the API Key if available.+apiKey :: MonadSync m => SyncM m (Maybe Text)+apiKey = getApiKey . getGuiConfig <$> config++-- | Return the completion percentage (0 to 100) for a given device and+-- folder.+completion :: MonadSync m => Device -> FolderName -> SyncM m Int+completion device folder = getCompletion <$> completion'+ where+ completion' = query $ getRequest { path = "/rest/completion"+ , params = [ ("device", device)+ , ("folder", folder) ]+ }++-- | Get the list of current connections and some metadata associated+-- with the connection/peer.+connections :: MonadSync m => SyncM m (M.Map Device Connection)+connections = query $ getRequest { path = "/rest/connections" }++-- | Verifiy and format a device ID. Return either a valid device ID in+-- modern format, or an error.+deviceId :: MonadSync m => Device -> SyncM m Device+deviceId = deviceId' >=> either (liftLeft . InvalidDeviceId) liftRight+ where+ deviceId' :: MonadSync m => Device -> SyncM m (Either DeviceError Device)+ deviceId' device = query $ getRequest { path = "/rest/deviceid"+ , params = [("id", device)]+ }++-- | Fetch the contents of the local discovery cache.+discovery :: MonadSync m => SyncM m (M.Map Device [CacheEntry])+discovery = query $ getRequest { path = "/rest/discovery" }++-- | Get the list of recent errors.+errors :: MonadSync m => SyncM m [Error]+errors = getErrors <$> errors'+ where+ errors' = query $ getRequest { path = "/rest/errors" }++-- | Fetch the ignores list.+ignores :: MonadSync m => FolderName -> SyncM m Ignore+ignores folder = query $ getRequest { path = "/rest/ignores"+ , params = [ ("folder", folder) ]+ }++-- | Get information about the current status of a folder.+model :: MonadSync m => FolderName -> SyncM m Model+model folder = query $ getRequest { path = "/rest/model"+ , params = [("folder", folder)]+ }++-- | Get lists of files which are needed by this device in order for it+-- to become in sync.+need :: MonadSync m => FolderName -> SyncM m Need+need folder = query $ getRequest { path = "/rest/need"+ , params = [ ("folder", folder) ]+ }++-- | Determine whether the config is in sync.+sync :: MonadSync m => SyncM m Bool+sync = getSync <$> sync'+ where+ sync' = query $ getRequest { path = "/rest/config/sync" }++-- | Returns information about current system status and resource usage.+system :: MonadSync m => SyncM m System+system = query $ getRequest { path = "/rest/system" }++-- | Get the directory tree of the global model.+tree :: MonadSync m + => FolderName -- ^ root folder+ -> Maybe Path -- ^ defines a prefix within the tree where to start building the structure+ -> Maybe Int -- ^ defines how deep within the tree we want to dwell down (0 based, defaults to unlimited depth) + -> SyncM m (Maybe DirTree)+tree folder prefix levels = + queryMaybe $ getRequest { path = "/rest/tree"+ , params = [("folder", folder)] ++ optionals+ }+ where + optionals = catMaybes [("prefix",) <$> prefix, ("levels",) <$> levelsText]+ levelsText = pack . show <$> levels++-- | Check for a possible upgrade.+upgrade :: MonadSync m => SyncM m Upgrade+upgrade = query $ getRequest { path = "/rest/upgrade" }++-- | Get the current syncthing version information.+version :: MonadSync m => SyncM m Version+version = query $ getRequest { path = "/rest/version" }+
+ Network/Syncthing/Internal.hs view
@@ -0,0 +1,23 @@++{-# OPTIONS_HADDOCK not-home #-}++-- | Internal constructors and helper functions. You should NOT use this+-- module under normal circumstances! +module Network.Syncthing.Internal (+ -- * Configuration+ module Network.Syncthing.Internal.Config+ -- * The Syncthing Monad+ , module Network.Syncthing.Internal.Monad+ -- * Requests+ , module Network.Syncthing.Internal.Request+ -- * Error Handling+ , module Network.Syncthing.Internal.Error+ ) where+++import Network.Syncthing.Internal.Config+import Network.Syncthing.Internal.Error+import Network.Syncthing.Internal.Monad hiding (liftEither,+ liftInner, liftReader)+import Network.Syncthing.Internal.Request+
+ Network/Syncthing/Internal/Config.hs view
@@ -0,0 +1,38 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.Syncthing.Internal.Config+ ( SyncConfig(..)+ ) where++import qualified Data.Text as T+import Network.HTTP.Client (Manager, ManagerSettings)+import qualified Network.Wreq as W++import Network.Syncthing.Types.Common (Server)+++-- | The Syncthing configuration for specifying the Syncthing server,+-- authentication, the API Key etc.+data SyncConfig = SyncConfig {+ _pServer :: Server+ , _pApiKey :: Maybe T.Text+ , _pAuth :: Maybe W.Auth+ , _pHttps :: Bool+ , _pManager :: Either ManagerSettings Manager+ }++instance Show SyncConfig where+ show SyncConfig{..} =+ concat [ "SyncConfig { "+ , "pServer = ", show _pServer+ , ", pApiKey = ", show _pApiKey+ , ", pAuth = ", show _pAuth+ , ", pHttps = ", show _pHttps+ , ", pManager = ", case _pManager of+ Left _ -> "Left _"+ Right _ -> "Right _"+ , " }"+ ]+
+ Network/Syncthing/Internal/Error.hs view
@@ -0,0 +1,68 @@++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Internal.Error+ ( DeviceError(..)+ , SyncError(..)+ , decodeDeviceError+ , decodeError+ ) where++import Control.Exception (Exception)+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.List (find)+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Text.Regex.Posix ((=~))+++data DeviceError =+ IncorrectLength+ | IncorrectCheckDigit+ | OtherDeviceError T.Text+ deriving (Eq, Show)++data SyncError =+ ParseError String+ | NotAuthorized+ | CSRFError+ | NotFound+ | InvalidDeviceId DeviceError+ | NoSuchFolder+ deriving (Typeable, Eq, Show)++instance Exception SyncError+++deviceIdLength, deviceIdCheckDigit :: String+deviceIdLength = "device ID invalid: incorrect length"+deviceIdCheckDigit = "check digit incorrect"++decodeError :: BS.ByteString -> Maybe SyncError+decodeError =+ fmap snd+ . flip find errorPatterns+ . (\msg patTup -> msg =~ fst patTup)+ . BS.unpack+ where+ errorPatterns :: [(String, SyncError)]+ errorPatterns =+ [ ("CSRF Error", CSRFError)+ , ("Not Authorized", NotAuthorized)+ , ("404 page not found", NotFound)+ , (deviceIdLength, InvalidDeviceId IncorrectLength)+ , (deviceIdCheckDigit, InvalidDeviceId IncorrectCheckDigit)+ , ("no such folder", NoSuchFolder )+ , ("Folder .*? does not exist", NoSuchFolder )+ ]++decodeDeviceError :: T.Text -> DeviceError+decodeDeviceError msg =+ fromMaybe (OtherDeviceError msg) $+ lookup (T.unpack msg)+ [ (deviceIdLength, IncorrectLength)+ , (deviceIdCheckDigit, IncorrectCheckDigit)+ ]+
+ Network/Syncthing/Internal/Lens.hs view
@@ -0,0 +1,16 @@++{-# LANGUAGE TemplateHaskell #-}++module Network.Syncthing.Internal.Lens+ ( pServer+ , pApiKey+ , pAuth+ , pHttps+ , pManager+ ) where++import Control.Lens (makeLenses)+import Network.Syncthing.Internal.Config (SyncConfig)++$(makeLenses ''SyncConfig)+
+ Network/Syncthing/Internal/Monad.hs view
@@ -0,0 +1,54 @@++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Internal.Monad+ ( SyncResult + , SyncM(..)+ , MonadSync(..)+ , liftEither+ , liftReader+ , liftInner+ , liftLeft+ , liftRight+ ) where++import Control.Applicative (Applicative)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Either (EitherT, left, right)+import Control.Monad.Trans.Reader (ReaderT)+import Data.Aeson (Value)+import Data.ByteString.Lazy (ByteString)+import qualified Network.Wreq as W++import Network.Syncthing.Internal.Config+import Network.Syncthing.Internal.Error+++-- | The result type of Syncthing requests.+type SyncResult a = Either SyncError a++-- | The SyncM Monad represents one or multiple Syncthing requests.+newtype SyncM m a = SyncM {+ runSyncthing :: EitherT SyncError (ReaderT SyncConfig m) a+ } deriving (Functor , Applicative , Monad)++class Monad m => MonadSync m where+ getMethod :: W.Options -> String -> m ByteString+ postMethod :: W.Options -> String -> Value -> m ByteString++liftEither :: Monad m => EitherT SyncError (ReaderT SyncConfig m) a -> SyncM m a+liftEither = SyncM++liftReader :: Monad m => (ReaderT SyncConfig m) a -> SyncM m a+liftReader = liftEither . lift++liftInner :: Monad m => m a -> SyncM m a+liftInner = liftEither . lift . lift++liftLeft :: Monad m => SyncError -> SyncM m a+liftLeft = liftEither . left++liftRight :: Monad m => a -> SyncM m a+liftRight = liftEither . right+
+ Network/Syncthing/Internal/Request.hs view
@@ -0,0 +1,103 @@++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Internal.Request+ ( Param+ , HttpMethod(..)+ , SyncRequest(..)+ , query+ , queryMaybe+ , send+ , get+ , post+ , getRequest+ , postRequest+ ) where++import Control.Lens ((&), (.~), (^.))+import Control.Monad ((<=<), (>=>))+import Control.Monad.Trans.Reader (ask)+import Data.Aeson +import Data.ByteString.Lazy (ByteString)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import qualified Network.Wreq as W++import Network.Syncthing.Internal.Config+import Network.Syncthing.Internal.Error+import Network.Syncthing.Internal.Lens+import Network.Syncthing.Internal.Monad+++type Param = (T.Text, T.Text)++data HttpMethod =+ Get+ | Post Value+ deriving (Eq, Show)++data SyncRequest = SyncRequest {+ path :: String+ , method :: HttpMethod+ , params :: [Param]+ } deriving (Eq, Show)++query :: (MonadSync m, FromJSON a) => SyncRequest -> SyncM m a+query = either (liftLeft . ParseError) liftRight . eitherDecode <=< request++queryMaybe :: (MonadSync m, FromJSON a) => SyncRequest -> SyncM m (Maybe a)+queryMaybe = request >=> \case+ "" -> liftRight Nothing+ bs -> liftRight $ decode bs++send :: MonadSync m => SyncRequest -> SyncM m ()+send = const (liftRight ()) <=< request++request :: MonadSync m => SyncRequest -> SyncM m ByteString+request req = do+ config <- liftReader ask+ let opts = prepareOptions config (params req) W.defaults+ let server = T.unpack $ config ^. pServer+ let proto = if (config ^. pHttps) then "https://" else "http://"+ let url = concat [proto, server, path req]+ liftInner $+ case method req of+ Get -> getMethod opts url+ Post payload -> postMethod opts url payload++prepareOptions :: SyncConfig -> [Param] -> W.Options -> W.Options+prepareOptions cfg params' =+ setManager (cfg ^. pManager)+ . setApiKey (cfg ^. pApiKey)+ . setAuth (cfg ^. pAuth)+ . setParams+ . setJsonHeader+ where+ setManager mgr = (& W.manager .~ mgr)+ setAuth authInfo = (& W.auth .~ authInfo)+ setJsonHeader = (& W.header "Accept" .~ ["application/json"])+ setParams = (& W.params .~ params')+ setApiKey (Just apiKey) = (& W.header "X-API-Key" .~ [encodeUtf8 apiKey])+ setApiKey Nothing = id++get :: HttpMethod+get = Get++post :: ToJSON a => a -> HttpMethod+post = Post . toJSON++getRequest :: SyncRequest+getRequest = SyncRequest {+ path = "/rest/ping"+ , method = get+ , params = []+ }++postRequest :: SyncRequest+postRequest = SyncRequest {+ path = "/rest/ping"+ , method = post ()+ , params = []+ }+
+ Network/Syncthing/Internal/Utils.hs view
@@ -0,0 +1,51 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Internal.Utils+ ( parseAddr+ , encodeAddr+ , toUTC+ , fromUTC+ ) where++import Control.Applicative ((<$>))+import Control.Arrow (second, (***))+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Data.Time.Clock (UTCTime)+import Data.Time.Format (formatTime, parseTime)+import System.Locale (defaultTimeLocale)+import Text.Regex.Posix ((=~))++import Network.Syncthing.Types.Common+++-- | Parse server string (SERVER:PORT) into an address type.+parseAddr :: Server -> Addr+parseAddr s =+ if serverString =~ ("^[^:]+:[0-9]+$" :: String)+ then mapAddr . split (== ':') $ serverString+ else (T.pack serverString, Nothing)+ where+ serverString = T.unpack s+ mapAddr :: (String, String) -> Addr+ mapAddr = T.pack *** (Just . read)++split :: (Char -> Bool) -> String -> (String, String)+split p = (second $ drop 1) . break p++-- | Generate server string.+encodeAddr :: Addr -> Server+encodeAddr (host, maybePort) = host `T.append` portSuffix+ where+ portSuffix = fromMaybe "" portPart+ portPart = T.pack . (:) ':' . show <$> maybePort++-- | Convert time string to UTCTime type.+toUTC :: String -> Maybe UTCTime+toUTC = parseTime defaultTimeLocale "%FT%X%Q%z"++-- | Generate time string from UTC.+fromUTC :: UTCTime -> String+fromUTC = formatTime defaultTimeLocale "%FT%X%Q%z"+
+ Network/Syncthing/Post.hs view
@@ -0,0 +1,123 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module : Network.Syncthing.Post+-- Copyright : (c) 2014 Jens Thomas+--+-- License : BSD-style+-- Maintainer : jetho@gmx.de+-- Stability : experimental+-- Portability : GHC+--+-- Syncthing POST requests.++module Network.Syncthing.Post+ (+ -- * Request functions+ ping+ , bump+ , hint+ , sendConfig+ , sendError+ , clearErrors+ , sendIgnores+ , scanFolder+ , reset+ , restart+ , shutdown+ , upgrade+ ) where++import Control.Applicative ((<$>))+import Control.Monad (join, (>=>))+import qualified Data.Map as Map+import Data.Maybe (maybeToList)+import Data.Text (Text)++import Network.Syncthing.Internal.Monad+import Network.Syncthing.Internal.Request+import Network.Syncthing.Types+++maybeSystemMsg :: MonadSync m => SyncRequest -> SyncM m (Maybe SystemMsg)+maybeSystemMsg = queryMaybe >=> return . join++-- | Ping the Syncthing server. Returns the string \"pong\".+ping :: MonadSync m => SyncM m Text+ping = getPing <$> ping'+ where+ ping' = query $ postRequest { path = "/rest/ping" }++-- | Move the given file to the top of the download queue.+bump :: MonadSync m => FolderName -> Path -> SyncM m Need+bump folder filePath =+ query $ postRequest { path = "/rest/bump"+ , params = [ ("folder", folder) , ("file", filePath) ]+ }++-- | Add an entry to the discovery cache.+hint:: MonadSync m => Device -> Server -> SyncM m ()+hint device server=+ send $ postRequest { path = "/rest/discovery/hint"+ , params = [("device", device), ("addr", server)]+ }++-- | Update the server configuration. The configuration will be saved to+-- disk and the configInSync flag set to false. +-- 'Network.Syncthing.Post.restart' Syncthing to activate.+sendConfig :: MonadSync m => Config -> SyncM m ()+sendConfig cfg = send $ postRequest { path = "/rest/config"+ , method = post cfg+ }++-- | Register a new error message.+sendError :: MonadSync m => Text -> SyncM m ()+sendError msg = send $ postRequest { path = "/rest/error"+ , method = post msg+ }++-- | Remove all recent errors.+clearErrors :: MonadSync m => SyncM m ()+clearErrors = send $ postRequest { path = "/rest/error/clear" }++-- | Update the ignores list and echo it back as response.+sendIgnores :: MonadSync m => FolderName -> [Text] -> SyncM m (Maybe [Text])+sendIgnores folder ignores =+ getIgnores <$> query postRequest { path = "/rest/ignores"+ , method = post ignoresMap+ , params = [("folder", folder)]+ }+ where+ ignoresMap :: Map.Map Text [Text]+ ignoresMap = Map.singleton "ignore" ignores++-- | Request rescan of a folder. Restrict the scan to a relative subpath+-- within the folder by specifying the optional path parameter.+scanFolder:: MonadSync m => FolderName -> Maybe Path -> SyncM m ()+scanFolder folder subPath =+ send $ postRequest { path = "/rest/scan"+ , params = [("folder", folder)]+ ++ maybeToList (("sub",) <$> subPath)+ }++-- | Restart Syncthing.+restart :: MonadSync m => SyncM m SystemMsg+restart = query postRequest { path = "/rest/restart" }++-- | Shutdown Syncthing.+shutdown :: MonadSync m => SyncM m SystemMsg+shutdown = query postRequest { path = "/rest/shutdown" }++-- | Reset Syncthing by renaming all folder directories to temporary,+-- unique names, wiping all indexes and restarting.+reset :: MonadSync m => SyncM m SystemMsg+reset = query postRequest { path = "/rest/reset" }++-- | Perform an upgrade to the newest release and restart. Does nothing if+-- there is no newer version.+upgrade :: MonadSync m => SyncM m (Maybe SystemMsg)+upgrade = maybeSystemMsg $ postRequest { path = "/rest/upgrade" }+
+ Network/Syncthing/Session.hs view
@@ -0,0 +1,113 @@++{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Network.Syncthing.Session+-- Copyright : (c) 2014 Jens Thomas+--+-- License : BSD-style+-- Maintainer : jetho@gmx.de+-- Stability : experimental+-- Portability : GHC+--+-- This module provides functions for manual session handling.+--+-- __/Example Usage:/__+--+-- @+-- \{\-\# LANGUAGE OverloadedStrings \#\-\}+--+-- import "Control.Lens" (('Control.Lens.&'), ('Control.Lens..~'))+-- import "Network.Syncthing"+-- import "Network.Syncthing.Session"+-- import qualified "Network.Syncthing.Get" as Get+--+-- \-\- Customized configuration.+-- settings1 = 'defaultConfig' 'Control.Lens.&' 'Network.Syncthing.pServer' 'Control.Lens..~' \"192.168.0.10:8080\"+--+-- session1 = do+-- session <- 'newSyncSession' settings1+-- p <- 'runSyncSession' session Get.'Network.Syncthing.Get.ping'+-- v <- 'runSyncSession' session Get.'Network.Syncthing.Get.version'+-- 'closeSyncSession' session+-- return (p, v)+--+-- \-\- Customized configuration with disabled SSL certificate verification.+-- settings2 = 'defaultConfig' 'Control.Lens.&' 'Network.Syncthing.pHttps' 'Control.Lens..~' True+-- 'Control.Lens.&' 'Network.Syncthing.pManager' 'Control.Lens..~' Left 'Network.Syncthing.noSSLVerifyManagerSettings'+--+-- session2 = do+-- session <- 'newSyncSession' settings2+-- p <- 'runSyncSession' session Get.'Network.Syncthing.Get.ping'+-- v <- 'runSyncSession' session Get.'Network.Syncthing.Get.version'+-- 'closeSyncSession' session+-- return (p, v)+-- @++module Network.Syncthing.Session+ (+ -- * Types+ SyncSession++ -- * Session Management+ , newSyncSession+ , closeSyncSession+ , withSyncSession++ -- * Running requests+ , runSyncSession+ ) where++import Control.Exception (bracket)+import Control.Lens ((&), (.~), (^.))+import Network.HTTP.Client (closeManager, newManager)++import Network.Syncthing+++-- | Holds the session configuration and the connection manager.+newtype SyncSession = SyncSession { getConfig :: SyncConfig }++-- | Create a new Syncthing session for with provided configuration. You should+-- reuse the session whenever possible because of connection sharing.+newSyncSession :: SyncConfig -> IO SyncSession+newSyncSession config = do+ mgr <- createManager $ config ^. pManager+ return . SyncSession $ config & pManager .~ Right mgr+ where+ createManager (Left settings) = newManager settings+ createManager (Right mgr) = return mgr++-- | Close a Syncthing session.+closeSyncSession :: SyncSession -> IO ()+closeSyncSession session = either doNothing closeManager mgr+ where+ doNothing = const $ return ()+ mgr = getConfig session ^. pManager++-- | Run a Syncthing request using connection sharing within a session.+runSyncSession :: SyncSession -> SyncM IO a -> IO (SyncResult a)+runSyncSession = syncthing . getConfig++-- | Create a new session using the provided configuration, run the+-- action and close the session.+--+-- /Examples:/+--+-- @+-- 'withSyncSession' 'defaultConfig' $ \\session ->+-- 'runSyncSession' session $ 'Control.Monad.liftM2' (,) Get.'Network.Syncthing.Get.ping' Get.'Network.Syncthing.Get.version'+-- @+-- @+-- import qualified "Network.Wreq" as Wreq+--+-- let cfg = 'defaultConfig' 'Control.Lens.&' 'pHttps' 'Control.Lens..~' True+-- 'Control.Lens.&' 'pAuth' 'Control.Lens.?~' Wreq.'Network.Wreq.basicAuth' \"user\" \"pass\"+-- 'Control.Lens.&' 'pApiKey' 'Control.Lens.?~' \"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXX\"+-- 'withSyncSession' cfg $ \\session ->+-- 'runSyncSession' session $ 'Control.Monad.liftM2' (,) Get.'Network.Syncthing.Get.ping' Get.'Network.Syncthing.Get.version'+-- @+withSyncSession :: SyncConfig -> (SyncSession -> IO a) -> IO a+withSyncSession config = bracket (newSyncSession config) closeSyncSession+
+ Network/Syncthing/Types.hs view
@@ -0,0 +1,24 @@++module Network.Syncthing.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+
+ Network/Syncthing/Types/CacheEntry.hs view
@@ -0,0 +1,29 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.CacheEntry+ ( CacheEntry(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+import Data.Text ()+import Data.Time.Clock (UTCTime)++import Network.Syncthing.Internal.Utils (parseAddr, toUTC)+import Network.Syncthing.Types.Common (Addr)+++-- | Represents an entry in the discovery cache.+data CacheEntry = CacheEntry {+ getAddr :: Addr+ , getSeen :: Maybe UTCTime+ } deriving (Eq, Show)++instance FromJSON CacheEntry where+ parseJSON (Object v) =+ CacheEntry <$> (parseAddr <$> (v .: "Address"))+ <*> (toUTC <$> (v .: "Seen"))+ parseJSON _ = mzero+
+ Network/Syncthing/Types/Common.hs view
@@ -0,0 +1,37 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.Common+ (+ Server+ , Device+ , FolderName+ , Path+ , Host+ , Port+ , Addr+ , defaultFolder+ ) where++import Data.Text (Text)+++-- | Use the SERVER:PORT format for specifying servers.+type Server = Text++type Device = Text++type FolderName = Text++type Path = Text++type Host = Text++type Port = Int++type Addr = (Host, Maybe Port)++-- | The default folder name.+defaultFolder :: FolderName+defaultFolder = "default"+
+ Network/Syncthing/Types/Completion.hs view
@@ -0,0 +1,19 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.Completion+ ( Completion(..)+ ) where++import Control.Applicative ((<$>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+++newtype Completion = Completion { getCompletion :: Int } + deriving (Eq, Show)++instance FromJSON Completion where+ parseJSON (Object v) = Completion <$> (v .: "completion")+ parseJSON _ = mzero+
+ Network/Syncthing/Types/Config.hs view
@@ -0,0 +1,322 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.Syncthing.Types.Config+ ( Config(..)+ , FolderConfig(..)+ , DeviceConfig(..)+ , VersioningConfig(..)+ , OptionsConfig(..)+ , GuiConfig(..)+ , AddressType(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Text (Text, cons, uncons)++import Network.Syncthing.Types.Common+import Network.Syncthing.Internal.Utils++++-------------------------------------------------------------------------------+-- CONFIG RECORD -----+-------------------------------------------------------------------------------++-- | The current configuration data structure.+data Config = Config {+ getConfigVersion :: Int+ , getFolderConfigs :: [FolderConfig]+ , getDeviceConfigs :: [DeviceConfig]+ , getGuiConfig :: GuiConfig+ , getOptionsConfig :: OptionsConfig+ } deriving (Eq, Show)++instance FromJSON Config where+ parseJSON (Object v) =+ Config <$> (v .: "Version")+ <*> (v .: "Folders")+ <*> (v .: "Devices")+ <*> (v .: "GUI")+ <*> (v .: "Options")+ parseJSON _ = mzero++instance ToJSON Config where+ toJSON Config{..} =+ object [ "Version" .= getConfigVersion+ , "Folders" .= getFolderConfigs+ , "Devices" .= getDeviceConfigs+ , "GUI" .= getGuiConfig+ , "Options" .= getOptionsConfig+ ]+++-------------------------------------------------------------------------------+-- ADDRESS TYPE -----+-------------------------------------------------------------------------------++-- | An address can be dynamic or static.+data AddressType =+ Dynamic+ | Address Addr+ deriving (Eq, Show)++decodeAddressType :: Text -> AddressType+decodeAddressType "dynamic" = Dynamic+decodeAddressType addr = Address $ parseAddr addr++encodeAddressType :: AddressType -> Text+encodeAddressType Dynamic = "dynamic"+encodeAddressType (Address addr) = encodeAddr addr+++-------------------------------------------------------------------------------+-- FOLDER CONFIG -----+-------------------------------------------------------------------------------++-- | The folder specific configuration.+data FolderConfig = FolderConfig {+ getId :: FolderName+ , getPath :: Path+ , getFolderDevices :: [Device]+ , getReadOnly :: Bool+ , getRescanIntervalS :: Int+ , getIgnorePerms :: Bool+ , getVersioning :: VersioningConfig+ , getLenientMtimes :: Bool+ , getCopiers :: Int+ , getPullers :: Int+ , getFolderInvalid :: Text+ } deriving (Eq, Show)++instance FromJSON FolderConfig where+ parseJSON (Object v) =+ FolderConfig <$> (v .: "ID")+ <*> (v .: "Path")+ <*> (map getFolderDevice <$> (v .: "Devices"))+ <*> (v .: "ReadOnly")+ <*> (v .: "RescanIntervalS")+ <*> (v .: "IgnorePerms")+ <*> (v .: "Versioning")+ <*> (v .: "LenientMtimes")+ <*> (v .: "Copiers")+ <*> (v .: "Pullers")+ <*> (v .: "Invalid")+ parseJSON _ = mzero++instance ToJSON FolderConfig where+ toJSON FolderConfig{..} =+ object [ "ID" .= getId+ , "Path" .= getPath+ , "Devices" .= map FolderDeviceConfig getFolderDevices+ , "ReadOnly" .= getReadOnly+ , "RescanIntervalS" .= getRescanIntervalS+ , "IgnorePerms" .= getIgnorePerms+ , "Versioning" .= getVersioning+ , "LenientMtimes" .= getLenientMtimes+ , "Copiers" .= getCopiers+ , "Pullers" .= getPullers+ , "Invalid" .= getFolderInvalid+ ]+++-------------------------------------------------------------------------------+-- VERSIONING CONFIG -----+-------------------------------------------------------------------------------++-- | Information about versioning.+data VersioningConfig = VersioningConfig {+ getType :: Text+ , getParams :: M.Map Text Text+ } deriving (Eq, Show)++instance FromJSON VersioningConfig where+ parseJSON (Object v) =+ VersioningConfig <$> (v .: "Type")+ <*> (v .: "Params")+ parseJSON _ = mzero++instance ToJSON VersioningConfig where+ toJSON VersioningConfig{..} =+ object [ "Type" .= getType+ , "Params" .= getParams+ ]+++-------------------------------------------------------------------------------+-- DEVICE CONFIG -----+-------------------------------------------------------------------------------++-- | Device specific configuration information.+data DeviceConfig = DeviceConfig {+ getDevice :: Device+ , getDeviceName :: Text+ , getAddresses :: [AddressType]+ , getCompression :: Bool+ , getCertName :: Text+ , getIntroducer :: Bool+ } deriving (Eq, Show)++instance FromJSON DeviceConfig where+ parseJSON (Object v) =+ DeviceConfig <$> (v .: "DeviceID")+ <*> (v .: "Name")+ <*> (map decodeAddressType <$> (v .: "Addresses"))+ <*> (v .: "Compression")+ <*> (v .: "CertName")+ <*> (v .: "Introducer")+ parseJSON _ = mzero++instance ToJSON DeviceConfig where+ toJSON DeviceConfig{..} =+ object [ "DeviceID" .= getDevice+ , "Name" .= getDeviceName+ , "Addresses" .= map encodeAddressType getAddresses+ , "Compression" .= getCompression+ , "CertName" .= getCertName+ , "Introducer" .= getIntroducer+ ]+++-------------------------------------------------------------------------------+-- FOLDER-DEVICE CONFIG -----+-------------------------------------------------------------------------------++data FolderDeviceConfig = FolderDeviceConfig {+ getFolderDevice :: Device+ } deriving (Eq, Show)++instance FromJSON FolderDeviceConfig where+ parseJSON (Object v) = FolderDeviceConfig <$> (v .: "DeviceID")+ parseJSON _ = mzero++instance ToJSON FolderDeviceConfig where+ toJSON (FolderDeviceConfig device) =+ object [ "DeviceID" .= device ]+++-------------------------------------------------------------------------------+-- GUI CONFIG -----+-------------------------------------------------------------------------------++-- | Gui settings.+data GuiConfig = GuiConfig {+ getEnabled :: Bool+ , getApiKey :: Maybe Text+ , getGuiAddress :: Addr+ , getUser :: Text+ , getPassword :: Text+ , getUseTLS :: Bool+ } deriving (Eq, Show)++instance FromJSON GuiConfig where+ parseJSON (Object v) =+ GuiConfig <$> (v .: "Enabled")+ <*> (decodeApiKey <$> (v .: "APIKey"))+ <*> (parseAddr <$> (v .: "Address"))+ <*> (v .: "User")+ <*> (v .: "Password")+ <*> (v .: "UseTLS")+ parseJSON _ = mzero++instance ToJSON GuiConfig where+ toJSON GuiConfig{..} =+ object [ "Enabled" .= getEnabled+ , "APIKey" .= encodeApiKey getApiKey+ , "Address" .= encodeAddr getGuiAddress+ , "User" .= getUser+ , "Password" .= getPassword+ , "UseTLS" .= getUseTLS+ ]++decodeApiKey :: Text -> Maybe Text+decodeApiKey = (uncurry cons `fmap`) . uncons++encodeApiKey :: Maybe Text -> Text+encodeApiKey = fromMaybe ""+++-------------------------------------------------------------------------------+-- OPTIONS CONFIG -----+-------------------------------------------------------------------------------++-- | Various config settings.+data OptionsConfig = OptionsConfig {+ getListenAddress :: [Addr]+ , getGlobalAnnServers :: [Text]+ , getGlobalAnnEnabled :: Bool+ , getLocalAnnEnabled :: Bool+ , getLocalAnnPort :: Int+ , getLocalAnnMCAddr :: Text+ , getMaxSendKbps :: Int+ , getMaxRecvKbps :: Int+ , getReconnectIntervalS :: Int+ , getStartBrowser :: Bool+ , getUPnPEnabled :: Bool+ , getUPnPLease :: Int+ , getUPnPRenewal :: Int+ , getURAccepted :: Int+ , getURUniqueID :: Text+ , getRestartOnWakeup :: Bool+ , getAutoUpgradeIntervalH :: Int+ , getKeepTemporariesH :: Int+ , getCacheIgnoredFiles :: Bool+ , getProgressUpdateIntervalS :: Int+ , getSymlinksEnabled :: Bool+} deriving (Eq, Show)++instance FromJSON OptionsConfig where+ parseJSON (Object v) =+ OptionsConfig <$> (map parseAddr <$> (v .: "ListenAddress"))+ <*> (v .: "GlobalAnnServers")+ <*> (v .: "GlobalAnnEnabled")+ <*> (v .: "LocalAnnEnabled")+ <*> (v .: "LocalAnnPort")+ <*> (v .: "LocalAnnMCAddr")+ <*> (v .: "MaxSendKbps")+ <*> (v .: "MaxRecvKbps")+ <*> (v .: "ReconnectIntervalS")+ <*> (v .: "StartBrowser")+ <*> (v .: "UPnPEnabled")+ <*> (v .: "UPnPLease")+ <*> (v .: "UPnPRenewal")+ <*> (v .: "URAccepted")+ <*> (v .: "URUniqueID")+ <*> (v .: "RestartOnWakeup")+ <*> (v .: "AutoUpgradeIntervalH")+ <*> (v .: "KeepTemporariesH")+ <*> (v .: "CacheIgnoredFiles")+ <*> (v .: "ProgressUpdateIntervalS")+ <*> (v .: "SymlinksEnabled")+ parseJSON _ = mzero++instance ToJSON OptionsConfig where+ toJSON OptionsConfig{..} =+ object [ "ListenAddress" .= map encodeAddr getListenAddress+ , "GlobalAnnServers" .= getGlobalAnnServers+ , "GlobalAnnEnabled" .= getGlobalAnnEnabled+ , "LocalAnnEnabled" .= getLocalAnnEnabled+ , "LocalAnnPort" .= getLocalAnnPort+ , "LocalAnnMCAddr" .= getLocalAnnMCAddr+ , "MaxSendKbps" .= getMaxSendKbps+ , "MaxRecvKbps" .= getMaxRecvKbps+ , "ReconnectIntervalS" .= getReconnectIntervalS+ , "StartBrowser" .= getStartBrowser+ , "UPnPEnabled" .= getUPnPEnabled+ , "UPnPLease" .= getUPnPLease+ , "UPnPRenewal" .= getUPnPRenewal+ , "URAccepted" .= getURAccepted+ , "URUniqueID" .= getURUniqueID+ , "RestartOnWakeup" .= getRestartOnWakeup+ , "AutoUpgradeIntervalH" .= getAutoUpgradeIntervalH+ , "KeepTemporariesH" .= getKeepTemporariesH+ , "CacheIgnoredFiles" .= getCacheIgnoredFiles+ , "ProgressUpdateIntervalS" .= getProgressUpdateIntervalS+ , "SymlinksEnabled" .= getSymlinksEnabled+ ]+
+ Network/Syncthing/Types/Connection.hs view
@@ -0,0 +1,35 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.Connection+ ( Connection(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+import Data.Text (Text)+import Data.Time.Clock (UTCTime)++import Network.Syncthing.Types.Common (Addr)+import Network.Syncthing.Internal.Utils (parseAddr, toUTC)+++-- | Connection information and some associated metadata.+data Connection = Connection {+ getAt :: Maybe UTCTime+ , getInBytesTotal :: Integer+ , getOutBytesTotal :: Integer+ , getAddress :: Addr+ , getClientVersion :: Text+ } deriving (Eq, Show)++instance FromJSON Connection where+ parseJSON (Object v) =+ Connection <$> (toUTC <$> (v .: "At"))+ <*> (v .: "InBytesTotal")+ <*> (v .: "OutBytesTotal")+ <*> (parseAddr <$> (v .: "Address"))+ <*> (v .: "ClientVersion")+ parseJSON _ = mzero+
+ Network/Syncthing/Types/DeviceId.hs view
@@ -0,0 +1,26 @@++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.DeviceId where++import Control.Applicative ((<$>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+import Data.HashMap.Lazy (member)+import Data.Text ()++import Network.Syncthing.Internal.Error+import Network.Syncthing.Types.Common+++instance FromJSON (Either DeviceError Device) where+ parseJSON (Object v) = result+ where hasId = member "id" v+ result = parseIdResult hasId v+ parseJSON _ = mzero++parseIdResult hasId v+ | hasId = Right <$> v .: "id"+ | otherwise = Left <$> (decodeDeviceError <$> v .: "error")+
+ Network/Syncthing/Types/DirTree.hs view
@@ -0,0 +1,35 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.DirTree+ ( DirTree(..)+ ) where++import Control.Applicative ((<$>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON)+import qualified Data.Map as M+import Data.Text (Text)+++-- | A directory tree contains files or subdirectories.+data DirTree + = Dir {+ getDirContents :: M.Map Text DirTree+ }+ | File {+ getModTime :: Integer -- ^ file modification time+ , getFileSize :: Integer -- ^ file size+ } + deriving (Eq, Show)++instance FromJSON DirTree where+ parseJSON obj@(Object _) = Dir <$> parseJSON obj+ parseJSON arr@(Array _) = decodeFile <$> parseJSON arr+ parseJSON _ = mzero+++decodeFile :: [Integer] -> DirTree+decodeFile [modTime, fileSize] = File modTime fileSize+decodeFile _ = File 0 0+
+ Network/Syncthing/Types/Error.hs view
@@ -0,0 +1,36 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.Error+ ( Error(..)+ , Errors(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+import Data.Text (Text)+import Data.Time.Clock (UTCTime)++import Network.Syncthing.Internal.Utils (toUTC)+++-- | An error message and its timestamp.+data Error = Error {+ getTime :: Maybe UTCTime+ , getMsg :: Text+ } deriving (Eq, Show)++newtype Errors = Errors { getErrors :: [Error] }+ deriving (Eq, Show)++instance FromJSON Error where+ parseJSON (Object v) =+ Error <$> (toUTC <$> (v .: "Time"))+ <*> (v .: "Error")+ parseJSON _ = mzero++instance FromJSON Errors where+ parseJSON (Object v) = Errors <$> (v .: "errors")+ parseJSON _ = mzero+
+ Network/Syncthing/Types/Ignore.hs view
@@ -0,0 +1,25 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.Ignore+ ( Ignore(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:?))+import Data.Text (Text)+++-- | Contains the ignores list and a list of all compiled ignore patterns.+data Ignore = Ignore {+ getIgnores :: Maybe [Text]+ , getPatterns :: Maybe [Text]+ } deriving (Eq, Show)++instance FromJSON Ignore where+ parseJSON (Object v) =+ Ignore <$> (v .:? "ignore")+ <*> (v .:? "patterns")+ parseJSON _ = mzero+
+ Network/Syncthing/Types/Model.hs view
@@ -0,0 +1,73 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.Model+ ( Model(..)+ , ModelState(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+import Data.Text (Text)+import Data.Time.Clock (UTCTime)++import Network.Syncthing.Internal.Utils (toUTC)+++-- | The current state of activity of a folder.+data ModelState+ = Idle+ | Scanning+ | Cleaning+ | Syncing+ deriving (Eq, Show)++-- | Information about the current status of a folder.+data Model = Model {+ getGlobalBytes :: Integer+ , getGlobalDeleted :: Integer+ , getGlobalFiles :: Integer+ , getInSyncBytes :: Integer+ , getInSyncFiles :: Integer+ , getLocalBytes :: Integer+ , getLocalDeleted :: Integer+ , getLocalFiles :: Integer+ , getNeedBytes :: Integer+ , getNeedFiles :: Integer+ , getState :: Maybe ModelState+ , getStateChanged :: Maybe UTCTime+ , getInvalid :: Maybe Text+ , getModelVersion :: Int+ } deriving (Eq, Show)++instance FromJSON Model where+ parseJSON (Object v) =+ Model <$> (v .: "globalBytes")+ <*> (v .: "globalDeleted")+ <*> (v .: "globalFiles")+ <*> (v .: "inSyncBytes")+ <*> (v .: "inSyncFiles")+ <*> (v .: "localBytes")+ <*> (v .: "localDeleted")+ <*> (v .: "localFiles")+ <*> (v .: "needBytes")+ <*> (v .: "needFiles")+ <*> (decodeModelState <$> (v .: "state"))+ <*> (toUTC <$> (v .: "stateChanged"))+ <*> (decodeInvalid <$> (v .: "invalid"))+ <*> (v .: "version")+ parseJSON _ = mzero++decodeModelState :: Text -> Maybe ModelState+decodeModelState = flip lookup+ [ ("idle", Idle)+ , ("scanning", Scanning)+ , ("cleaning", Cleaning)+ , ("syncing", Syncing)+ ]++decodeInvalid :: Text -> Maybe Text+decodeInvalid "" = Nothing+decodeInvalid s = Just s+
+ Network/Syncthing/Types/Need.hs view
@@ -0,0 +1,51 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.Need+ ( Need(..)+ , Progress(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+import Data.Text (Text)+++-- | Contains lists of files which are needed by a device for becoming in+-- sync.+data Need = Need {+ getProgress :: [Progress]+ , getQueued :: [Text]+ , getRest :: [Text]+ } deriving (Eq, Show)++-- | A file that is currently downloading. +data Progress = Progress { + getName :: Text+ , getFlags :: Int+ , getModified :: Integer+ , getProgressVersion :: Int+ , getLocalVersion :: Int+ , getNumBlocks :: Int+ , getSize :: Integer+ } deriving (Eq, Show)++instance FromJSON Progress where+ parseJSON (Object v) =+ Progress <$> (v .: "Name")+ <*> (v .: "Flags")+ <*> (v .: "Modified")+ <*> (v .: "Version")+ <*> (v .: "LocalVersion")+ <*> (v .: "NumBlocks")+ <*> (v .: "Size")+ parseJSON _ = mzero++instance FromJSON Need where+ parseJSON (Object v) =+ Need <$> (v .: "progress")+ <*> (v .: "queued")+ <*> (v .: "rest")+ parseJSON _ = mzero+
+ Network/Syncthing/Types/Ping.hs view
@@ -0,0 +1,19 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.Ping+ ( Ping(..)+ ) where++import Control.Applicative ((<$>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+import Data.Text (Text)++newtype Ping = Ping { getPing :: Text } + deriving (Eq, Show)++instance FromJSON Ping where+ parseJSON (Object v) = Ping <$> (v .: "ping")+ parseJSON _ = mzero+
+ Network/Syncthing/Types/Sync.hs view
@@ -0,0 +1,19 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.Sync+ ( Sync(..)+ ) where++import Control.Applicative ((<$>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+++newtype Sync = Sync { getSync :: Bool } + deriving (Eq, Show)++instance FromJSON Sync where+ parseJSON (Object v) = Sync <$> (v .: "configInSync")+ parseJSON _ = mzero+
+ Network/Syncthing/Types/System.hs view
@@ -0,0 +1,36 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.System+ ( System(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:), (.:?))+import qualified Data.Map as M+import Data.Text (Text)++import Network.Syncthing.Types.Common (Server)+++-- | Information about the system status and resource usage.+data System = System {+ getAlloc :: Integer+ , getCpuPercent :: Double+ , getExtAnnounceOK :: Maybe (M.Map Server Bool)+ , getGoRoutines :: Int+ , getMyId :: Text+ , getSys :: Integer+ } deriving (Eq, Show)++instance FromJSON System where+ parseJSON (Object v) =+ System <$> (v .: "alloc")+ <*> (v .: "cpuPercent")+ <*> (v .:? "extAnnounceOK")+ <*> (v .: "goroutines")+ <*> (v .: "myID")+ <*> (v .: "sys")+ parseJSON _ = mzero+
+ Network/Syncthing/Types/SystemMsg.hs view
@@ -0,0 +1,35 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.SystemMsg+ ( SystemMsg(..)+ ) where++import Control.Applicative ((<$>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+++-- | System messages.+data SystemMsg+ = Restarting+ | ShuttingDown+ | ResettingFolders+ | OtherSystemMsg Text+ deriving (Eq, Show)++instance FromJSON SystemMsg where+ parseJSON (Object v) = decodeSystemMsg <$> (v .: "ok")+ parseJSON _ = mzero++decodeSystemMsg :: Text -> SystemMsg+decodeSystemMsg msg = fromMaybe (OtherSystemMsg msg) maybeMsg+ where + maybeMsg = lookup msg+ [ ("restarting", Restarting)+ , ("shutting down", ShuttingDown)+ , ("resetting folders", ResettingFolders)+ ]+
+ Network/Syncthing/Types/Upgrade.hs view
@@ -0,0 +1,27 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.Upgrade+ ( Upgrade(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+import Data.Text (Text)+++-- | Information about the current software version and upgrade possibilities.+data Upgrade = Upgrade {+ getLatest :: Text+ , getNewer :: Bool+ , getRunning :: Text+ } deriving (Eq, Show)++instance FromJSON Upgrade where+ parseJSON (Object v) =+ Upgrade <$> (v .: "latest")+ <*> (v .: "newer")+ <*> (v .: "running")+ parseJSON _ = mzero+
+ Network/Syncthing/Types/Version.hs view
@@ -0,0 +1,29 @@++{-# LANGUAGE OverloadedStrings #-}++module Network.Syncthing.Types.Version+ ( Version(..)+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (MonadPlus (mzero))+import Data.Aeson (FromJSON, Value (..), parseJSON, (.:))+import Data.Text (Text)+++-- | Current Syncthing version information.+data Version = Version {+ getArch :: Text+ , getLongVersion :: Text+ , getOs :: Text+ , getVersion :: Text+ } deriving (Eq, Show)++instance FromJSON Version where+ parseJSON (Object v) =+ Version <$> (v .: "arch")+ <*> (v .: "longVersion")+ <*> (v .: "os")+ <*> (v .: "version")+ parseJSON _ = mzero+
+ README.md view
@@ -0,0 +1,51 @@++syncthing-hs +============++[](https://travis-ci.org/jetho/syncthing-hs)++Haskell bindings for the [Syncthing REST API](https://github.com/syncthing/syncthing/wiki/REST-Interface).++Tutorial+--------++A short tutorial is available at: +[http://jetho.org/posts/2015-03-07-syncthing-hs-tutorial.html](http://jetho.org/posts/2015-03-07-syncthing-hs-tutorial.html)+++Installation+------------++ cabal update+ cabal install syncthing-hs++Usage Example+-------------++``` haskell+{-# LANGUAGE OverloadedStrings #-}++import qualified Network.Wreq as Wreq+import Control.Monad (liftM2)+import Control.Lens ((&), (.~), (?~))+import Network.Syncthing+import qualified Network.Syncthing.Get as Get++-- A single Syncthing request.+single = syncthing defaultConfig Get.ping++-- Connection sharing for multiple Syncthing requests.+multiple1 = withManager $ \cfg ->+ syncthing cfg $ do+ p <- Get.ping+ v <- Get.version+ return (p, v)++-- Multiple Syncthing requests with connection sharing and customized configuration.+multiple2 = withManager $ \cfg -> do+ let cfg' = cfg & pServer .~ "192.168.0.10:8080"+ & pHttps .~ True+ & pAuth ?~ Wreq.basicAuth "user" "pass"+ syncthing cfg' $ liftM2 (,) Get.ping Get.version+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ syncthing-hs.cabal view
@@ -0,0 +1,103 @@+name: syncthing-hs+version: 0.1.0.0+synopsis: Haskell bindings for the Syncthing REST API+description: + .+ see: <https://github.com/syncthing/syncthing/wiki/REST-Interface>+ .+ A short tutorial is available at: + <http://jetho.org/posts/2015-03-07-syncthing-hs-tutorial.html>+homepage: https://github.com/jetho/syncthing-hs+bug-reports: https://github.com/jetho/syncthing-hs/issues+license: BSD3+license-file: LICENSE+author: Jens Thomas+maintainer: jetho@gmx.de+-- copyright: +category: Network+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ ghc-options: -Wall -fno-warn-orphans+ exposed-modules: Network.Syncthing + Network.Syncthing.Session+ Network.Syncthing.Get+ Network.Syncthing.Post+ Network.Syncthing.Internal+ 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.Utils+ Network.Syncthing.Types+ Network.Syncthing.Types.CacheEntry+ Network.Syncthing.Types.Common+ Network.Syncthing.Types.Completion+ Network.Syncthing.Types.Config+ Network.Syncthing.Types.Connection+ Network.Syncthing.Types.DeviceId+ Network.Syncthing.Types.DirTree+ Network.Syncthing.Types.Error+ Network.Syncthing.Types.Ignore+ Network.Syncthing.Types.Model+ Network.Syncthing.Types.Need+ Network.Syncthing.Types.Ping+ Network.Syncthing.Types.Sync+ Network.Syncthing.Types.System+ Network.Syncthing.Types.SystemMsg+ Network.Syncthing.Types.Upgrade+ Network.Syncthing.Types.Version+ -- other-extensions: + build-depends: aeson >=0.8.0.1+ , base >=4.5 && <5+ , bytestring >=0.9+ , connection >= 0.2.3+ , containers >= 0.5.5.1+ , 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+ -- hs-source-dirs: + default-language: Haskell2010++test-Suite tests+ type: exitcode-stdio-1.0+ main-is: Test.hs+ build-depends: aeson >=0.8.0.1+ , base >=4.5 && <5+ , bytestring >=0.9+ , connection >= 0.2.3+ , containers >= 0.5.5.1+ , 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+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ hs-source-dirs: tests, .+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/jetho/syncthing-hs+
+ tests/Test.hs view
@@ -0,0 +1,23 @@++module Main where++import Test.Tasty++import Properties.ErrorProperties+import Properties.JsonProperties+import UnitTests.Errors+import UnitTests.Requests+++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [properties, unitTests]++properties :: TestTree+properties = testGroup "Properties" [jsonProps, errorProps]++unitTests :: TestTree+unitTests = testGroup "Unit Tests" [errorUnits, requestUnits]+