packages feed

heyefi 1.1.0.0 → 2.0.0.0

raw patch · 25 files changed

+796/−322 lines, 25 filesdep −containers

Dependencies removed: containers

Files

+ README.md view
@@ -0,0 +1,57 @@+# heyefi++heyefi is a Linux system daemon that listens for Eye-Fi SD card and processes the requested file upload requests made by the card. This project is not endorsed by Eye-Fi Inc.++# Installation++heyefi is meant to be run as a system daemon. It currently needs to run as root, to make the file permissions part work with less configuration. (It currently sets the permissions of the files to the same as the upload directory. Let me know if you have ideas on how to do that [without being root](https://github.com/ryantm/heyefi/issues/4)!) It expects a configuration file to be at /etc/heyefi/heyefi.config.++This program is available through Nix, and it can be easily installed on Nixos. It can be installed on any Linux distribution like this:++1. Put a configuration file at /etc/heyefi/heyefi.config (format described in the "Configuration" section below)+2. Install Nix `curl https://nixos.org/nix/install | sh`+3. Install heyefi `nix-env -iA nixpkgs.heyefi`. The server binary should now be on your path as `heyefi`.+4. Find the absolute path of heyefi with `readlink $(which heyefi)` (For example, on one system it was /nix/store/b4m467s0byr1v2xfd7acwpq5x4l2dp8f-heyefi-1.1.0.0/bin/heyefi)+5. Make a systemd service (or whatever equivalent for your system) that runs the server binary as the root user++# Configuration++The configuration file has the following options:++cards: a list of Eye-Fi card credentials. The format of the list is [["macaddress1","uploadkey1"],["macaddress2","uploadkey2"],...]++upload_dir: an string that is an absolute path to where the files get put after they come off the card.++Complete example config with two cards:++```haskell+cards = [["0012342de4ce","e7403a0123402ca062"],["1234562d5678","12342a062"]]+upload_dir = "/data/unsorted"+```++# NixOS configuration++There is a NixOS service definition for heyefi. It currently only supports one card's credentials.++Complete example configuration:++```nix+{+  services.heyefi.enable = true;+  services.heyefi.cardMacaddress = "0012342de4ce";+  services.heyefi.uploadKey = "e7403a0123402ca062";+  services.heyefi.uploadDir = /data/unsorted;+}+```++# Development++```bash+nix-shell+```+++# Changelog++2.0.0.0 2017-11-18 Program output should be immediately written to stdout, instead of being buffered until the program finishes.+1.1.0.0 2017-01-02 fixed build of version 0.13.0.0 of optparse-applicative, which removes Data.Monoid exports
heyefi.cabal view
@@ -1,101 +1,139 @@+-- This file has been generated from package.yaml by hpack version 0.18.1.+--+-- see: https://github.com/sol/hpack+ name:                heyefi-version:             1.1.0.0+version:             2.0.0.0 synopsis:            A server for Eye-Fi SD cards. description:         This server listens for Eye-Fi cards that want to upload files to a computer and stores them in an upload directory. It is meant to be run as a system daemon.+category:            Network homepage:            https://github.com/ryantm/heyefi-license:             PublicDomain-license-file:        LICENSE+bug-reports:         https://github.com/ryantm/heyefi/issues author:              Ryan Mulligan maintainer:          ryan@ryantm.com-category:            Network+license:             PublicDomain+license-file:        LICENSE build-type:          Simple-cabal-version:       >=1.10+cabal-version:       >= 1.10 +extra-source-files:+    README.md+ source-repository head   type: git   location: https://github.com/ryantm/heyefi  executable heyefi-  default-language:    Haskell2010-  hs-source-dirs:      src-  main-is:             HEyefi/Main.hs-  other-modules:       HEyefi.App-                     , HEyefi.Constant-                     , HEyefi.Config-                     , HEyefi.Hex-                     , HEyefi.Log-                     , HEyefi.Soap-                     , HEyefi.SoapResponse-                     , HEyefi.Types-                     , HEyefi.UploadPhoto-                     , HEyefi.StartSession-                     , HEyefi.Strings-                     , HEyefi.CommandLineOptions-  ghc-options:         -Wall-  build-depends:       base >=4.8 && <=5-                     , stm-                     , unix-                     , MissingH-                     , bytestring-                     , utf8-string-                     , time-                     , iso8601-time-                     , warp-                     , wai-                     , http-types-                     , HandsomeSoup-                     , hxt-                     , case-insensitive-                     , multipart-                     , tar-                     , configurator-                     , unordered-containers-                     , text-                     , temporary-                     , directory-                     , filepath-                     , mtl-                     , transformers-                     , exceptions-                     , random-                     , optparse-applicative+  main-is: HEyefi/Main.hs+  hs-source-dirs:+      src+  default-extensions: OverloadedStrings ScopedTypeVariables GeneralizedNewtypeDeriving NoImplicitPrelude+  ghc-options: -Wall+  build-depends:+      base >=4.8 && <=5+    , stm+    , unix+    , MissingH+    , bytestring+    , utf8-string+    , time+    , iso8601-time+    , warp+    , wai+    , http-types+    , HandsomeSoup+    , hxt+    , case-insensitive+    , multipart+    , tar+    , configurator+    , unordered-containers+    , text+    , temporary+    , directory+    , filepath+    , mtl+    , transformers+    , exceptions+    , random+    , optparse-applicative+  other-modules:+      HEyefi.App+      HEyefi.CommandLineOptions+      HEyefi.Config+      HEyefi.Constant+      HEyefi.Hex+      HEyefi.Log+      HEyefi.Prelude+      HEyefi.Soap+      HEyefi.SoapResponse+      HEyefi.StartSession+      HEyefi.Texts+      HEyefi.Types+      HEyefi.UploadPhoto+  default-language: Haskell2010 -test-suite test-heyefi+test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+      src+  default-extensions: OverloadedStrings ScopedTypeVariables GeneralizedNewtypeDeriving NoImplicitPrelude+  ghc-options: -Wall+  build-depends:+      base >=4.8 && <=5+    , stm+    , unix+    , MissingH+    , bytestring+    , utf8-string+    , time+    , iso8601-time+    , warp+    , wai+    , http-types+    , HandsomeSoup+    , hxt+    , case-insensitive+    , multipart+    , tar+    , configurator+    , unordered-containers+    , text+    , temporary+    , directory+    , filepath+    , mtl+    , transformers+    , exceptions+    , random+    , optparse-applicative+    , hspec+    , hspec-wai+    , wai-extra+    , silently+  other-modules:+      HEyefi.AppSpec+      HEyefi.ConfigSpec+      HEyefi.LogSpec+      HEyefi.SoapResponseSpec+      HEyefi.SoapSpec+      HEyefi.SpecPrelude+      HEyefi.StartSessionSpec+      HEyefi.UploadPhotoSpec+      HEyefi.App+      HEyefi.CommandLineOptions+      HEyefi.Config+      HEyefi.Constant+      HEyefi.Hex+      HEyefi.Log+      HEyefi.Main+      HEyefi.Prelude+      HEyefi.Soap+      HEyefi.SoapResponse+      HEyefi.StartSession+      HEyefi.Texts+      HEyefi.Types+      HEyefi.UploadPhoto   default-language: Haskell2010-  type:             exitcode-stdio-1.0-  hs-source-dirs:   test, src-  main-is:          Spec.hs-  ghc-options:      -Wall-  build-depends:    base >=4.8 && <=5-                  , stm-                  , unix-                  , containers-                  , hspec-                  , hspec-wai-                  , MissingH-                  , bytestring-                  , utf8-string-                  , time-                  , iso8601-time-                  , warp-                  , wai-                  , wai-extra-                  , http-types-                  , HandsomeSoup-                  , hxt-                  , case-insensitive-                  , multipart-                  , tar-                  , configurator-                  , unordered-containers-                  , text-                  , silently-                  , filepath-                  , directory-                  , temporary-                  , directory-                  , mtl-                  , transformers-                  , exceptions-                  , random-                  , optparse-applicative
src/HEyefi/App.hs view
@@ -1,17 +1,18 @@-{-# LANGUAGE OverloadedStrings #-}- module HEyefi.App where +import           Control.Concurrent.STM (+    atomically+  , writeTVar+  , readTVar )+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import           Data.Maybe (isJust, fromJust, isNothing) import           HEyefi.Config (runWithConfig) import           HEyefi.Log (logDebug)+import           HEyefi.Prelude import           HEyefi.Soap (handleSoapAction, soapAction)-import           HEyefi.Strings import           HEyefi.Types (SharedConfig, HEyefiApplication) import           HEyefi.UploadPhoto (handleUpload)--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import           Data.Maybe (isJust, fromJust, isNothing) import           Network.Wai (     Application   , Request@@ -19,18 +20,14 @@   , requestBody   , requestMethod   , requestHeaders )-import           Control.Concurrent.STM (-    atomically-  , writeTVar-  , readTVar )  app :: SharedConfig -> Application app sharedConfig req f = do   config <- atomically (readTVar sharedConfig)   body <- getWholeRequestBody req   (result, config') <- runWithConfig config (do-                  logDebug (show (pathInfo req))-                  logDebug (show (requestHeaders req))+                  logDebug (tshow (pathInfo req))+                  logDebug (tshow (requestHeaders req))                   dispatchRequest (BL.fromStrict body) req f)   atomically (writeTVar sharedConfig config')   return result@@ -45,7 +42,7 @@   | requestMethod req == "POST" &&     isJust (soapAction req) =       handleSoapAction (fromJust (soapAction req)) body req f-dispatchRequest _ _ _ = error didNotMatchDispatch+dispatchRequest _ _ _ = terror didNotMatchDispatch  getWholeRequestBody :: Request -> IO B.ByteString getWholeRequestBody request = do
src/HEyefi/CommandLineOptions.hs view
@@ -1,6 +1,6 @@ module HEyefi.CommandLineOptions where -import HEyefi.Strings+import HEyefi.Prelude  import Data.Monoid ((<>)) import Data.Version (showVersion)@@ -12,8 +12,8 @@ opts :: ParserInfo (Maybe ()) opts = info (helper <*> parser)        ( fullDesc-         <> progDesc programDescription-         <> header programHeaderDescription )+         <> progDesc (unpack programDescription)+         <> header (unpack programHeaderDescription) )  parser :: Parser (Maybe ()) parser =
src/HEyefi/Config.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE OverloadedStrings #-}- module HEyefi.Config where +import           HEyefi.Log (logInfo)+import           HEyefi.Prelude import           HEyefi.Types (     Config(..)   , CardConfig@@ -11,8 +11,6 @@   , uploadDirectory   , logLevel   , HEyefiM(..))-import           HEyefi.Log (logInfo)-import           HEyefi.Strings  import           Control.Concurrent.STM (     TVar@@ -27,14 +25,15 @@   , Handler (..)   , SomeException (..)) import           Control.Monad.IO.Class (liftIO)-import           Control.Monad.State.Lazy (get, put, runStateT)+import           Control.Monad.State.Lazy (modify, get, runStateT) import           Data.Configurator (load, Worth (Required), getMap) import           Data.Configurator.Types (Value, ConfigError (ParseError)) import qualified Data.Configurator.Types as CT import           Data.HashMap.Strict () import qualified Data.HashMap.Strict as HM import           Data.Maybe (mapMaybe)-import           Data.Text (Text, unpack, pack)+import           Data.Text (Text)+import qualified Data.Text as T  insertCard :: Text -> Text -> Config -> Config insertCard macAddress uploadKey c =@@ -53,7 +52,7 @@       Just _ -> writeTVar wakeSig Nothing       Nothing -> retry)) -convertCardList :: Value -> Either String [(Text, Text)]+convertCardList :: Value -> Either Text [(Text, Text)] convertCardList (CT.List innerList) =   Right (mapMaybe extractTuple innerList)   where@@ -78,9 +77,9 @@       Right cardList ->         return (HM.fromList cardList) -convertUploadDirectory :: Value -> Either String FilePath+convertUploadDirectory :: Value -> Either Text FilePath convertUploadDirectory (CT.String uploadDir) =-  Right (unpack uploadDir)+  Right (T.unpack uploadDir) convertUploadDirectory _ =   Left uploadDirFormatDoesNotMatch @@ -101,7 +100,7 @@  reloadConfig :: FilePath -> HEyefiM Config reloadConfig configPath = do-  logInfo (tryingToLoadConfiguration configPath)+  logInfo (tryingToLoadConfiguration (T.pack configPath))   catches (     do       config <- liftIO (load [Required configPath])@@ -116,10 +115,10 @@         lastSNonce = "" } -- TODO: Careful, we might be erasing something here.     )     [Handler (\(ParseError p msg) -> do-                 logInfo (errorParsingConfigurationFile p msg)+                 logInfo (errorParsingConfigurationFile (T.pack p) (T.pack msg))                  return emptyConfig),      Handler (\(SomeException _) -> do-                 logInfo (couldNotFindConfigurationFile configPath)+                 logInfo (couldNotFindConfigurationFile (T.pack configPath))                  return emptyConfig)]  runWithConfig :: Config -> HEyefiM a -> IO (a,Config)@@ -148,17 +147,12 @@         liftIO (atomically (writeTVar sharedConfig config)))     (waitForWake wakeSignal) -getUploadKeyForMacaddress :: String -> HEyefiM (Maybe String)+getUploadKeyForMacaddress :: Text -> HEyefiM (Maybe Text) getUploadKeyForMacaddress mac = do   c <- get-  return (fmap unpack (HM.lookup (pack mac) (cardMap c)))+  return (HM.lookup mac (cardMap c)) -putSNonce :: String -> HEyefiM ()-putSNonce snonce = do-  c <- get-  put Config {-          cardMap = cardMap c,-          uploadDirectory = uploadDirectory c,-          logLevel = logLevel c,-          lastSNonce = snonce-          }+putSNonce :: Text -> HEyefiM ()+putSNonce snonce =+  modify (\ s ->+            s { lastSNonce = snonce })
src/HEyefi/Constant.hs view
@@ -1,11 +1,13 @@ module HEyefi.Constant where +import HEyefi.Prelude+ port :: Int port = 59278 -configPath :: String+configPath :: Text configPath = "/etc/heyefi/heyefi.config" -multipartBodyBoundary :: String+multipartBodyBoundary :: Text multipartBodyBoundary =   "---------------------------02468ace13579bdfcafebabef00d"
src/HEyefi/Hex.hs view
@@ -1,13 +1,17 @@ module HEyefi.Hex where -unhex :: String -> Maybe String-unhex [] = Just []-unhex (a:b:xs) = do-  first <- c a-  second <- c b-  rest <- unhex xs-  return (toEnum ((first * 16) + second) : rest)-unhex _ = Nothing+import HEyefi.Prelude++unhex :: Text -> Maybe Text+unhex = unpack >>> go >>> fmap pack+  where+    go [] = Just []+    go (a:b:xs) = do+      first <- c a+      second <- c b+      rest <- go xs+      return (toEnum ((first * 16) + second) : rest)+    go _ = Nothing  c :: Char -> Maybe Int c '0' = Just 0
src/HEyefi/Log.hs view
@@ -1,27 +1,31 @@ module HEyefi.Log where--import HEyefi.Types (HEyefiM, LogLevel(..), logLevel)+import           HEyefi.Types (HEyefiM, LogLevel(..), logLevel)+import           HEyefi.Prelude -import Control.Monad.IO.Class (liftIO)-import Control.Monad.State.Lazy (get)-import Data.Time.Clock (getCurrentTime)-import Data.Time.ISO8601 (formatISO8601Millis)+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.State.Lazy (get)+import           Data.Monoid ((<>))+import           Data.Text (Text)+import qualified Data.Text.IO as T+import qualified Data.Text as T+import           Data.Time.Clock (getCurrentTime)+import           Data.Time.ISO8601 (formatISO8601Millis) -log' :: LogLevel -> String -> IO ()+log' :: LogLevel -> Text -> IO () log' ll s = do   t <- getCurrentTime-  putStrLn (unwords [-                 "[" ++ formatISO8601Millis t ++ "]"-               , "[" ++ show ll ++ "]"+  T.putStrLn (T.unwords [+                 "[" <> T.pack (formatISO8601Millis t) <> "]"+               , "[" <> T.pack (show ll) <> "]"                , s]) -logInfoIO :: String -> IO ()+logInfoIO :: Text -> IO () logInfoIO = log' Info -logInfo ::  String -> HEyefiM ()+logInfo ::  Text -> HEyefiM () logInfo = liftIO . logInfoIO -logDebug :: String -> HEyefiM ()+logDebug :: Text -> HEyefiM () logDebug s = do   config <- get   case logLevel config of
src/HEyefi/Main.hs view
@@ -1,25 +1,24 @@-{-# LANGUAGE OverloadedStrings #-}- module Main where -import           HEyefi.App (app)-import           HEyefi.CommandLineOptions (handleOptionsThenMaybe)-import           HEyefi.Config (monitorConfig, newConfig, runWithConfig)-import           HEyefi.Constant (port, configPath)-import           HEyefi.Log (logInfoIO)-import           HEyefi.Strings-import           HEyefi.Types (SharedConfig)+import HEyefi.App (app)+import HEyefi.CommandLineOptions (handleOptionsThenMaybe)+import HEyefi.Config (monitorConfig, newConfig, runWithConfig)+import HEyefi.Constant (port, configPath)+import HEyefi.Log (logInfoIO)+import HEyefi.Prelude+import HEyefi.Types (SharedConfig) -import           Control.Concurrent (forkIO)+import Control.Concurrent (forkIO) import           Control.Concurrent.STM (     newTVar   , atomically   , writeTVar   , TVar   , readTVar )-import           Control.Monad (forever, void)-import           Network.Wai.Handler.Warp (run)-import           System.Posix.Signals (installHandler, sigHUP, Handler( Catch ))+import Control.Monad (forever, void)+import Network.Wai.Handler.Warp (run)+import System.IO+import System.Posix.Signals (installHandler, sigHUP, Handler( Catch ))   handleHup :: TVar (Maybe Int) -> IO ()@@ -39,7 +38,7 @@           (do               c <- atomically (readTVar sharedConfig)               runWithConfig c (-                monitorConfig configPath sharedConfig wakeSig))))+                monitorConfig (unpack configPath) sharedConfig wakeSig))))  runHeyefi :: IO () runHeyefi = do@@ -48,8 +47,10 @@    readAndMonitorSharedConfig wakeSig sharedConfig -  logInfoIO (listeningOnPort (show port))+  logInfoIO (listeningOnPort (tshow port))   run port (app sharedConfig)  main :: IO ()-main = handleOptionsThenMaybe runHeyefi+main = do+  hSetBuffering stdout LineBuffering+  handleOptionsThenMaybe runHeyefi
+ src/HEyefi/Prelude.hs view
@@ -0,0 +1,33 @@+module HEyefi.Prelude (+  module X,+  Text,+  tshow,+  tmd5,+  tlength,+  terror,+  T.pack,+  T.unpack,+  T.writeFile,+  (<>)) where++import           Control.Category as X+import           Data.Hash.MD5 (md5s, Str (..))+import           Data.Monoid ((<>))+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import           HEyefi.Texts as X+import qualified Prelude as X hiding (String, writeFile, (.), id)+import           Prelude hiding ((.))++tshow :: Show a => a -> Text+tshow = show >>> T.pack++tlength :: Text -> Int+tlength = T.length++terror :: Text -> a+terror = T.unpack >>> error++tmd5 :: Text -> Text+tmd5  = T.unpack >>> Str >>> md5s >>> T.pack
src/HEyefi/Soap.hs view
@@ -1,18 +1,5 @@-{-# LANGUAGE OverloadedStrings #-}- module HEyefi.Soap where -import           HEyefi.Config (getUploadKeyForMacaddress)-import           HEyefi.Hex (unhex)-import           HEyefi.Log (logInfo, logDebug)-import           HEyefi.SoapResponse (-    markLastPhotoInRollResponse-  , getPhotoStatusResponse )-import           HEyefi.StartSession (startSessionResponse)-import           HEyefi.Strings-import           HEyefi.Types-- import           Control.Arrow ((>>>)) import           Control.Monad (join) import           Control.Monad.IO.Class (liftIO)@@ -23,14 +10,23 @@ import           Data.ByteString.Lazy.UTF8 (toString) import           Data.ByteString.UTF8 (fromString) import qualified Data.CaseInsensitive as CI-import           Data.Hash.MD5 (md5s, Str (..)) import           Data.List (find) import           Data.Maybe (fromJust, isJust)+import           Data.Text.Encoding (encodeUtf8) import           Data.Time.Clock (getCurrentTime, UTCTime) import           Data.Time.Format (     formatTime   , rfc822DateFormat   , defaultTimeLocale )+import           HEyefi.Config (getUploadKeyForMacaddress)+import           HEyefi.Hex (unhex)+import           HEyefi.Log (logInfo, logDebug)+import           HEyefi.Prelude+import           HEyefi.SoapResponse (+    markLastPhotoInRollResponse+  , getPhotoStatusResponse )+import           HEyefi.StartSession (startSessionResponse)+import           HEyefi.Types import           Network.HTTP.Types (status200, unauthorized401) import           Network.HTTP.Types.Header (     hContentType@@ -70,13 +66,13 @@ soapAction :: Request -> Maybe SoapAction soapAction req = firstJust headerToSoapAction (requestHeaders req) -mkResponse :: String -> HEyefiM Response+mkResponse :: Text -> HEyefiM Response mkResponse responseBody = do   t <- liftIO getCurrentTime   return (responseLBS           status200-          (defaultResponseHeaders t (length responseBody))-          (fromStrict (fromString responseBody)))+          (defaultResponseHeaders t (tlength responseBody))+          (fromStrict (encodeUtf8 responseBody)))  mkUnauthorizedResponse :: Response mkUnauthorizedResponse = responseLBS unauthorized401 [] ""@@ -92,10 +88,11 @@   , (hContentLength, fromString (show size))]  firstTag :: BL.ByteString ->-            String ->-            String+            Text ->+            Text firstTag body tagName =-  head (runLA (xreadDoc >>> css tagName /> getText) (toString body))+  pack (head (runLA (xreadDoc >>> css (unpack tagName) /> getText)+                (toString body)))  handleSoapAction :: SoapAction -> BL.ByteString -> HEyefiApplication handleSoapAction StartSession body _ f = do@@ -105,14 +102,14 @@   let cnonce = tag "cnonce"   let transfermode = tag "transfermode"   let transfermodetimestamp = tag "transfermodetimestamp"-  logDebug (show macaddress)-  logDebug (show transfermodetimestamp)+  logDebug macaddress+  logDebug transfermodetimestamp   responseBody <- startSessionResponse                    macaddress                    cnonce                    transfermode                    transfermodetimestamp-  logDebug (show responseBody)+  logDebug responseBody   response <- mkResponse responseBody   liftIO (f response) handleSoapAction GetPhotoStatus body _ f = do@@ -141,9 +138,9 @@      logInfo (noUploadKeyInConfiguration macaddress)      return False    Just upload_key_0' -> do-     let credentialString = macaddress ++ upload_key_0' ++ snonce+     let credentialString = macaddress <> upload_key_0' <> snonce      let binaryCredentialString = unhex credentialString-     let expectedCredential = md5s (Str (fromJust binaryCredentialString))+     let expectedCredential = tmd5 (fromJust binaryCredentialString)      if credential /= expectedCredential then do        logInfo (invalidCredential expectedCredential credential)        return False
src/HEyefi/SoapResponse.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE OverloadedStrings #-}- module HEyefi.SoapResponse where -import Control.Arrow ((>>>))+import           HEyefi.Prelude++import           Control.Arrow ((>>>))+import           Data.Text (Text)+import qualified Data.Text as T import Text.XML.HXT.Core (     runLA   , root@@ -27,9 +29,9 @@     [ sattr "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" ]     [ mkelem "SOAP-ENV:Body" [] body ]] -soapResponse :: [LA n XmlTree] -> String+soapResponse :: [LA n XmlTree] -> Text soapResponse body =-  head (runLA (document >>> writeDocumentToString []) undefined)+  T.pack (head (runLA (document >>> writeDocumentToString []) undefined))   where     document = root [] (soapMessage body) @@ -40,7 +42,7 @@     [ mkelem "success" [] [ txt "true" ] ]   ] -markLastPhotoInRollResponse :: String+markLastPhotoInRollResponse :: Text markLastPhotoInRollResponse = soapResponse markLastPhotoInRollBody  markLastPhotoInRollBody :: [LA n XmlTree]@@ -50,7 +52,7 @@       []   ] -getPhotoStatusResponse :: String+getPhotoStatusResponse :: Text getPhotoStatusResponse = soapResponse getPhotoStatusBody  getPhotoStatusBody :: [LA n XmlTree]
src/HEyefi/StartSession.hs view
@@ -1,19 +1,18 @@-{-# LANGUAGE OverloadedStrings #-}- module HEyefi.StartSession where -import HEyefi.Config (getUploadKeyForMacaddress, putSNonce)-import HEyefi.Hex (unhex)-import HEyefi.Log (logInfo)-import HEyefi.Types (HEyefiM(..))+import           HEyefi.Config (getUploadKeyForMacaddress, putSNonce)+import           HEyefi.Hex (unhex)+import           HEyefi.Log (logInfo)+import           HEyefi.Prelude+import           HEyefi.Types (HEyefiM(..)) -import Control.Arrow ((>>>))-import Control.Monad (replicateM)-import Control.Monad.IO.Class (liftIO)-import Data.Char (intToDigit)-import Data.Hash.MD5 (md5s, Str (..))-import Data.Maybe (fromJust)-import System.Random (randomRIO)+import           Control.Arrow ((>>>))+import           Control.Monad (replicateM)+import           Control.Monad.IO.Class (liftIO)+import           Data.Char (intToDigit)+import           Data.Maybe (fromJust)++import           System.Random (randomRIO) import Text.XML.HXT.Core ( runLA                          , mkelem                          , spi@@ -23,29 +22,30 @@                          , root                          , writeDocumentToString) -newServerNonce :: IO String-newServerNonce =-  replicateM 32 (do-                    i <- randomRIO (0, 15)-                    return (intToDigit i))+newServerNonce :: IO Text+newServerNonce = do+  string <- replicateM 32 (do+                            i <- randomRIO (0, 15)+                            return (intToDigit i))+  return (pack string) -startSessionResponse :: String ->-                        String ->-                        String ->-                        String ->-                        HEyefiM String+startSessionResponse :: Text ->+                        Text ->+                        Text ->+                        Text ->+                        HEyefiM Text startSessionResponse macaddress cnonce transfermode transfermodetimestamp = do   upload_key_0 <- getUploadKeyForMacaddress macaddress   case upload_key_0 of    Nothing -> do-     logInfo ("No upload key found in configuration for macaddress: " ++ macaddress)+     logInfo (noUploadKeyInConfiguration macaddress)      return ""    Just upload_key_0' -> do      snonce <- liftIO newServerNonce      putSNonce snonce-     let credentialString = macaddress ++ cnonce ++ upload_key_0'-     let binaryCredentialString = unhex credentialString-     let credential = md5s (Str (fromJust binaryCredentialString))+     let credentialText = macaddress <> cnonce <> upload_key_0'+     let binaryCredentialString = unhex credentialText+     let credential = tmd5 (fromJust binaryCredentialString)      let document =            root []            [ spi t_xml "version=\"1.0\" encoding=\"UTF-8\""@@ -54,14 +54,16 @@              [ mkelem "SOAP-ENV:Body" []                [ mkelem "StartSessionResponse"                  [ sattr "xmlns" "http://localhost/api/soap/eyefilm" ]-                 [ mkelem "credential" [] [ txt credential ]-                 , mkelem "snonce" [] [ txt snonce ]-                 , mkelem "transfermode" [] [ txt transfermode ]-                 , mkelem "transfermodetimestamp" [] [ txt transfermodetimestamp ]+                 [ mkelem "credential" [] [ txtT credential ]+                 , mkelem "snonce" [] [ txtT snonce ]+                 , mkelem "transfermode" [] [ txtT transfermode ]+                 , mkelem "transfermodetimestamp" [] [ txtT transfermodetimestamp ]                  , mkelem "upsyncallowed" [] [ txt "true" ]                  ]                ]              ]            ] -     return (head (runLA (document >>> writeDocumentToString []) undefined))+     return (pack (head (runLA (document >>> writeDocumentToString []) undefined)))+     where+       txtT = txt . unpack
− src/HEyefi/Strings.hs 
@@ -1,72 +0,0 @@-module HEyefi.Strings where--cardsFormatDoesNotMatch :: String-cardsFormatDoesNotMatch =-  "Format of cards does not match [[MacAddress, Key],[MacAddress, Key],...]."--missingCardsDefinition :: String-missingCardsDefinition = "Configuration is missing a definition for `cards`."--uploadDirFormatDoesNotMatch :: String-uploadDirFormatDoesNotMatch =-  "Format of upload_dir does not match \"/path/to/upload/dir\""--missingUploadDirDefinition :: String-missingUploadDirDefinition =-  "Configuration is missing a definition for `upload_dir`."---noUploadKeyInConfiguration :: String -> String-noUploadKeyInConfiguration =-  (++) "No upload key found in configuration for macaddress: "--invalidCredential :: String -> String -> String-invalidCredential expected actual =-  "Invalid credential in GetPhotoStatus request. Expected: "-   ++ expected ++ " Actual: " ++ actual--listeningOnPort :: String -> String-listeningOnPort = (++) "Listening on port "--gotStartSessionRequest :: String-gotStartSessionRequest = "Got StartSession request"--gotGetPhotoStatusRequest :: String-gotGetPhotoStatusRequest = "Got GetPhotoStatus request"--gotMarkLastPhotoInRollRequest :: String-gotMarkLastPhotoInRollRequest = "Got MarkLastPhotoInRoll request"--loadedConfiguration :: String-loadedConfiguration = "Loaded configuration"--tryingToLoadConfiguration :: String -> String-tryingToLoadConfiguration = (++) "Trying to load configuration at "--errorParsingConfigurationFile :: String -> String -> String-errorParsingConfigurationFile p msg =-  "Error parsing configuration file at " ++-  p ++-  " with message: " ++-  msg--couldNotFindConfigurationFile :: String -> String-couldNotFindConfigurationFile = (++) "Could not find configuration file at "--didNotMatchDispatch :: String-didNotMatchDispatch = "did not match dispatch"--notADefinedSoapAction :: String -> String-notADefinedSoapAction sa = sa ++ " is not a defined SoapAction yet"--programDescription :: String-programDescription = "A server daemon for Eye-Fi SD cards."--programHeaderDescription :: String-programHeaderDescription = "heyefi - a server for Eye-Fi SD cards"--gotUploadRequest :: String-gotUploadRequest = "Got Upload request"--uploadedTo :: String -> String-uploadedTo = (++) "Uploaded to "
+ src/HEyefi/Texts.hs view
@@ -0,0 +1,75 @@+module HEyefi.Texts where++import Data.Text (Text)+import Data.Monoid ((<>))++cardsFormatDoesNotMatch :: Text+cardsFormatDoesNotMatch =+  "Format of cards does not match [[MacAddress, Key],[MacAddress, Key],...]."++missingCardsDefinition :: Text+missingCardsDefinition = "Configuration is missing a definition for `cards`."++uploadDirFormatDoesNotMatch :: Text+uploadDirFormatDoesNotMatch =+  "Format of upload_dir does not match \"/path/to/upload/dir\""++missingUploadDirDefinition :: Text+missingUploadDirDefinition =+  "Configuration is missing a definition for `upload_dir`."+++noUploadKeyInConfiguration :: Text -> Text+noUploadKeyInConfiguration =+  (<>) "No upload key found in configuration for macaddress: "++invalidCredential :: Text -> Text -> Text+invalidCredential expected actual =+  "Invalid credential in GetPhotoStatus request. Expected: "+   <> expected <> " Actual: " <> actual++listeningOnPort :: Text -> Text+listeningOnPort = (<>) "Listening on port "++gotStartSessionRequest :: Text+gotStartSessionRequest = "Got StartSession request"++gotGetPhotoStatusRequest :: Text+gotGetPhotoStatusRequest = "Got GetPhotoStatus request"++gotMarkLastPhotoInRollRequest :: Text+gotMarkLastPhotoInRollRequest = "Got MarkLastPhotoInRoll request"++loadedConfiguration :: Text+loadedConfiguration = "Loaded configuration"++tryingToLoadConfiguration :: Text -> Text+tryingToLoadConfiguration = (<>) "Trying to load configuration at "++errorParsingConfigurationFile :: Text -> Text -> Text+errorParsingConfigurationFile p msg =+  "Error parsing configuration file at " <>+  p <>+  " with message: " <>+  msg++couldNotFindConfigurationFile :: Text -> Text+couldNotFindConfigurationFile = (<>) "Could not find configuration file at "++didNotMatchDispatch :: Text+didNotMatchDispatch = "did not match dispatch"++notADefinedSoapAction :: Text -> Text+notADefinedSoapAction sa = sa <> " is not a defined SoapAction yet"++programDescription :: Text+programDescription = "A server daemon for Eye-Fi SD cards."++programHeaderDescription :: Text+programHeaderDescription = "heyefi - a server for Eye-Fi SD cards"++gotUploadRequest :: Text+gotUploadRequest = "Got Upload request"++uploadedTo :: Text -> Text+uploadedTo = (<>) "Uploaded to "
src/HEyefi/Types.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- module HEyefi.Types where +import HEyefi.Prelude+ import           Control.Concurrent.STM (TVar) import           Control.Monad.Catch (MonadMask, MonadCatch, MonadThrow) import           Control.Monad.IO.Class (MonadIO)@@ -41,7 +41,7 @@   cardMap :: CardConfig,   uploadDirectory :: FilePath,   logLevel :: LogLevel,-  lastSNonce :: String+  lastSNonce :: Text }  type SharedConfig = TVar Config
src/HEyefi/UploadPhoto.hs view
@@ -1,18 +1,15 @@-{-# LANGUAGE OverloadedStrings #-}- module HEyefi.UploadPhoto where +import           Codec.Archive.Tar (extract)+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.State.Lazy (get)+import qualified Data.ByteString.Lazy as BL import           HEyefi.Constant (multipartBodyBoundary) import           HEyefi.Log (logDebug, logInfo)+import           HEyefi.Prelude import           HEyefi.Soap (mkResponse) import           HEyefi.SoapResponse (soapResponse, uploadPhotoResponse)-import           HEyefi.Strings import           HEyefi.Types (uploadDirectory, HEyefiM, HEyefiApplication)--import           Codec.Archive.Tar (extract)-import           Control.Monad.IO.Class (liftIO)-import           Control.Monad.State.Lazy (get)-import qualified Data.ByteString.Lazy as BL import           Network.Multipart (     parseMultipartBody   , MultiPart (..)@@ -29,6 +26,7 @@   , FileStatus )  + copyMatchingOwnership :: FileStatus -> FilePath -> FilePath -> IO FilePath copyMatchingOwnership fs from to = do   copyFile from to@@ -65,26 +63,28 @@ handleUpload :: BL.ByteString -> HEyefiApplication handleUpload body _ f = do   logDebug gotUploadRequest-  let MultiPart bodyParts = parseMultipartBody multipartBodyBoundary body-  logDebug (show (length bodyParts))+  let MultiPart bodyParts = parseMultipartBody (unpack multipartBodyBoundary) body+  logDebug (tshow (length bodyParts))   lBP bodyParts-  let (BodyPart _ soapEnvelope) = head bodyParts-  let (BodyPart _ file) = bodyParts !! 1-  let (BodyPart _ digest) = bodyParts !! 2 +  let [  BodyPart _ soapEnvelope+       , BodyPart _ file+       , BodyPart _ digest+       ] = bodyParts+   outputPath <- writeTarFile file-  logInfo (uploadedTo outputPath)+  logInfo (uploadedTo (pack outputPath)) -  logDebug (show soapEnvelope)-  logDebug (show digest)+  logDebug (tshow soapEnvelope)+  logDebug (tshow digest)   let responseBody = soapResponse uploadPhotoResponse-  logDebug (show responseBody)+  logDebug responseBody   r <- mkResponse responseBody   liftIO (f r)    where     lBP [] = return ()     lBP (BodyPart headers _ : xs) = do-      logDebug (show headers)+      logDebug (tshow headers)       lBP xs       return ()
+ test/HEyefi/AppSpec.hs view
@@ -0,0 +1,84 @@+module HEyefi.AppSpec where++import Control.Concurrent.STM+import Data.ByteString.Lazy (toStrict)+import Data.CaseInsensitive as CI+import Data.Text (Text, isInfixOf)+import Data.Text.Encoding (decodeUtf8)+import HEyefi.App+import HEyefi.Config+import HEyefi.SpecPrelude+import Network.HTTP.Types.Method+import Network.Wai (Application)+import Network.Wai.Test (SResponse (simpleBody))+import Test.Hspec.Wai+import Test.Hspec.Wai.Internal++++spec :: Spec+spec = do+  describe "StartSession" (+    it "should return expected body" (+       do+         a <- app'+         action <- runWaiSession sampleStartSessionRequest a+         responseBodyContains action sampleStartSessionResponse1 `shouldBe` True+         responseBodyContains action sampleStartSessionResponse2+           `shouldBe` True))+  with app' (+    do+      describe "MarkLastPhotoInRoll" (+        it "should respond with status 200" (+           sampleMarkLastPhotoRequest+           `shouldRespondWith`+           sampleMarkLastPhotoInRollResponse {matchStatus = 200}))+      describe "StartSession" (+        it "should respond with status 200" (+           sampleStartSessionRequest+           `shouldRespondWith` 200))+      describe "GetPhotoStatus" (+        it "should respond with status 200" (+           sampleStartSessionRequest+           `shouldRespondWith` 200)))++responseBodyContains :: SResponse -> Text -> Bool+responseBodyContains r t =+  t+  `isInfixOf`+  (decodeUtf8 . toStrict) (simpleBody r)++app' :: IO Application+app' = do+  sharedConfig <- atomically (newTVar (insertCard "0018562de4ce" "36d61e4e7403a0586702c9159892a062" emptyConfig))+  return (app sharedConfig)++sampleMarkLastPhotoRequest :: WaiSession SResponse+sampleMarkLastPhotoRequest =+  request+  methodPost "/"+  [(CI.mk "SoapAction",  "\"urn:MarkLastPhotoInRoll\"")]+  "<?xml version=\"1.0\" encoding=\"UTF-8\"?><SOAP-ENV:Envelope xmlns:SOAP-ENV=\"http://schemas.xmlsoap.org/soap/envelope/\" xmlns:ns1=\"EyeFi/SOAP/EyeFilm\"><SOAP-ENV:Body><ns1:MarkLastPhotoInRoll><macaddress>001856417729</macaddress><mergedelta>0</mergedelta></ns1:MarkLastPhotoInRoll></SOAP-ENV:Body></SOAP-ENV:Envelope>"++sampleMarkLastPhotoInRollResponse :: ResponseMatcher+sampleMarkLastPhotoInRollResponse = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><SOAP-ENV:Envelope xmlns:SOAP-ENV=\"http://schemas.xmlsoap.org/soap/envelope/\"><SOAP-ENV:Body><MarkLastPhotoInRollResponse xmlns=\"http://localhost/api/soap/eyefilm\"/></SOAP-ENV:Body></SOAP-ENV:Envelope>"++sampleStartSessionRequest :: WaiSession SResponse+sampleStartSessionRequest =+  request+  methodPost "/"+  [(CI.mk "SoapAction",  "\"urn:StartSession\"")]+  "<?xml version=\"1.0\" encoding=\"UTF-8\"?><SOAP-ENV:Envelope xmlns:SOAP-ENV=\"http://schemas.xmlsoap.org/soap/envelope/\" xmlns:ns1=\"EyeFi/SOAP/EyeFilm\"><SOAP-ENV:Body><ns1:StartSession><macaddress>0018562de4ce</macaddress><cnonce>6eb0444343c1953e47fb28181bb4e47f</cnonce><transfermode>34</transfermode><transfermodetimestamp>1356903384</transfermodetimestamp></ns1:StartSession></SOAP-ENV:Body></SOAP-ENV:Envelope>"++sampleStartSessionResponse1 :: Text+sampleStartSessionResponse1 = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><SOAP-ENV:Envelope xmlns:SOAP-ENV=\"http://schemas.xmlsoap.org/soap/envelope/\"><SOAP-ENV:Body><StartSessionResponse xmlns=\"http://localhost/api/soap/eyefilm\"><credential>f9d03ddcce53582ff10075577e522373</credential><snonce>"++sampleStartSessionResponse2 :: Text+sampleStartSessionResponse2 = "</snonce><transfermode>34</transfermode><transfermodetimestamp>1356903384</transfermodetimestamp><upsyncallowed>true</upsyncallowed></StartSessionResponse></SOAP-ENV:Body></SOAP-ENV:Envelope>"++sampleGetPhotoRequest :: WaiSession SResponse+sampleGetPhotoRequest =+  request+  methodPost "/"+  [(CI.mk "SoapAction",  "\"urn:GetPhotoRequest\"")]+  "<?xml version=\"1.0\" encoding=\"UTF-8\"?><SOAP-ENV:Envelope xmlns:SOAP-ENV=\"http://schemas.xmlsoap.org/soap/envelope/\" xmlns:ns1=\"EyeFi/SOAP/EyeFilm\"><SOAP-ENV:Body><ns1:GetPhotoStatus><credential>7daa9ecf3a9f135f5bb30541ed84fcfb</credential><macaddress>0018562de4ce</macaddress><filename>IMG_2195.JPG.tar</filename><filesize>125952</filesize><filesignature>736ffb7fa20f1708fd300c58c0aabb61</filesignature><flags>4</flags></ns1:GetPhotoStatus></SOAP-ENV:Body></SOAP-ENV:Envelope>"
+ test/HEyefi/ConfigSpec.hs view
@@ -0,0 +1,83 @@+module HEyefi.ConfigSpec where++import           Test.Hspec++import           HEyefi.Config+import           HEyefi.Prelude+import           HEyefi.Types (cardMap, uploadDirectory, Config)++import           Control.Exception (catch, SomeException, throwIO)+import qualified Data.HashMap.Strict as HM+import           System.Directory (getTemporaryDirectory, removeFile)+import           System.FilePath ((</>))+import           System.IO.Error (isDoesNotExistError)+import           System.IO.Silently (capture)++removeIfExists :: FilePath -> IO ()+removeIfExists fileName = removeFile fileName `catch` handleExists+  where handleExists e+          | isDoesNotExistError e = return ()+          | otherwise = throwIO e++getNonexistentTemporaryFile :: IO FilePath+getNonexistentTemporaryFile = do+  tempdir <- catch getTemporaryDirectory (\(_::SomeException) -> return ".")+  let file = tempdir </> "heyefi.config"+  removeIfExists file+  return file++makeAndReloadFile_ :: Text -> IO Text+makeAndReloadFile_ s = fmap fst (makeAndReloadFile s)++makeAndReloadFile :: Text -> IO (Text, Config)+makeAndReloadFile contents = do+  file <- getNonexistentTemporaryFile+  writeFile file contents+  (a,b) <- capture (do+                       r <- runWithEmptyConfig (reloadConfig file)+                       return (fst r))+  return (pack a, b)++validConfig :: Text+validConfig = "upload_dir = \"/data/photos\"\ncards = [[\"0012342de4ce\",\"e7403a0123402ca062\"],[\"1234562d5678\",\"12342a062\"]]"++spec :: Spec+spec =+  describe "reloadConfig" (do+    it "should report an error for a non-existent configuration file"+     (do+         file <- getNonexistentTemporaryFile+         (output, config) <- capture (+           do+             r <- runWithEmptyConfig (reloadConfig file)+             return (fst r))+         cardMap config `shouldBe` HM.empty+         output `shouldContain` "Could not find configuration file at " ++ file)+    it "should report an error for an unparsable configuration file"+     (do+         (output, config) <- makeAndReloadFile "a = (\n"+         cardMap config `shouldBe` HM.empty+         unpack output `shouldContain` "Error parsing configuration file at "+         unpack output `shouldContain` "with message: endOfInput")+    it "should complain about missing cards configuration"+     (do+         (output, config) <- makeAndReloadFile "upload_dir = \"/data/annex/doxie/unsorted\""+         cardMap config `shouldBe` HM.empty+         unpack output `shouldContain` "missing a definition for `cards`.")+    it "should complain about cards not having the correct format"+     (do+         (_, config) <- makeAndReloadFile "upload_dir = \"/data/annex/doxie/unsorted\"\ncards=[[\"1\",\"2\",\"3\"]]"+         cardMap config `shouldBe` HM.empty+         output2 <- makeAndReloadFile_ "upload_dir = \"/data/annex/doxie/unsorted\"\ncards=\"1\""+         unpack output2 `shouldContain` "Format of cards does not match")+    it "should complain about missing upload_dir configuration"+     (do+         (output, config) <-  makeAndReloadFile "cards = [[\"0012342de4ce\",\"e7403a0123402ca062\"],[\"1234562d5678\",\"12342a062\"]]"+         uploadDirectory config `shouldBe` ""+         unpack output `shouldContain`"missing a definition for `upload_dir`.")+    it "should parse cards for a valid configuration"+     (do+         (_, config) <- makeAndReloadFile validConfig+         uploadDirectory config `shouldBe` "/data/photos"+         HM.lookup "0012342de4ce" (cardMap config) `shouldBe` Just "e7403a0123402ca062"+         HM.lookup "1234562d5678" (cardMap config) `shouldBe` Just "12342a062"))
+ test/HEyefi/LogSpec.hs view
@@ -0,0 +1,36 @@+module HEyefi.LogSpec where++import Data.Time.Clock (getCurrentTime)+import Data.Time.Format (formatTime, defaultTimeLocale)+import HEyefi.Config+import HEyefi.Log+import HEyefi.Prelude+import HEyefi.SpecPrelude+import HEyefi.Types++currentTime :: IO Text+currentTime = do+  t <- getCurrentTime+  return (pack (formatTime defaultTimeLocale "%FT%T" t))++spec :: Spec+spec = do+  describe "logDebug" (do+    it "should output nothing when debugging is not enabled" (+        do+          result <- capture_ (runWithEmptyConfig (logDebug "hi"))+          result `shouldBe` "")+    it "should output somethign when debugging enabled" (+        do+          let config = emptyConfig { logLevel = Debug }+          result <- capture_ (runWithConfig config (logDebug "hi"))+          result `tshouldContain` "Debug"+          result `tshouldContain` "hi"))+  describe "logInfo"+    (it "should output something" (+        do+          result <- capture_ (runWithEmptyConfig (logInfo "hi"))+          time <- currentTime+          result `tshouldContain` time+          result `tshouldContain` "Info"+          result `tshouldContain` "hi"))
+ test/HEyefi/SoapResponseSpec.hs view
@@ -0,0 +1,10 @@+module HEyefi.SoapResponseSpec where++import HEyefi.SoapResponse+import HEyefi.SpecPrelude++spec :: Spec+spec =+  describe "getPhotoStatusResponse"+    (it "should have GetPhotoStatusResponse element"+     (getPhotoStatusResponse `tshouldContain` "GetPhotoStatusResponse"))
+ test/HEyefi/SoapSpec.hs view
@@ -0,0 +1,37 @@+module HEyefi.SoapSpec where++import HEyefi.SpecPrelude++import HEyefi.Soap+import HEyefi.Types+++intToMaybe :: Int -> Maybe Int+intToMaybe 5 = Just 5+intToMaybe 4 = Just 4+intToMaybe _ = Nothing++spec :: Spec+spec = do+  describe "firstJust" (+    do+      it "should handle an empty list"+        (firstJust intToMaybe [] `shouldBe` Nothing)+      it "should handle one not matched element"+        (firstJust intToMaybe [6] `shouldBe` Nothing)+      it "should handle one matched element"+        (firstJust intToMaybe [4] `shouldBe` Just 4)+      it "should get the first matched element"+        (firstJust intToMaybe [1,5,4] `shouldBe` Just 5))+  describe "headerToSoapAction" (+    do+      it "should return StartSession for one"+        (headerToSoapAction (soapActionHeaderName, "\"urn:StartSession\"")+            `shouldBe` Just StartSession)+      it "should return GetPhotoStatus for one"+        (headerToSoapAction (soapActionHeaderName, "\"urn:GetPhotoStatus\"")+            `shouldBe` Just GetPhotoStatus)+      it "should return MarkLastPhotoInRoll for one"+        (headerToSoapAction (soapActionHeaderName,+                             "\"urn:MarkLastPhotoInRoll\"")+            `shouldBe` Just MarkLastPhotoInRoll))
+ test/HEyefi/SpecPrelude.hs view
@@ -0,0 +1,17 @@+module HEyefi.SpecPrelude (+  module X,+  tshouldContain,+  capture_) where++import HEyefi.Prelude as X+import Test.Hspec as X+import qualified Test.Hspec as HS+import qualified System.IO.Silently as S++tshouldContain :: Text -> Text -> HS.Expectation+tshouldContain actual expected =+  unpack actual `shouldContain` unpack expected+++capture_ :: IO a -> IO Text+capture_ a = fmap pack (S.capture_ a)
+ test/HEyefi/StartSessionSpec.hs view
@@ -0,0 +1,21 @@+module HEyefi.StartSessionSpec where++import HEyefi.Config (emptyConfig, insertCard, runWithConfig)+import HEyefi.SpecPrelude+import HEyefi.StartSession++spec :: Spec+spec =+  describe "startSessionResponse"+    (it "should respond the same as eyefiserver2"+     (do+         let c = insertCard "0018562de4ce" "36d61e4e7403a0586702c9159892a062" emptyConfig+         (d , _) <- runWithConfig c (+           startSessionResponse+           "0018562de4ce"+           "3623cd00fe5aef4c7ccdc66ddbe2f151"+           "34"+           "1356903384")++         d `tshouldContain` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><SOAP-ENV:Envelope xmlns:SOAP-ENV=\"http://schemas.xmlsoap.org/soap/envelope/\"><SOAP-ENV:Body><StartSessionResponse xmlns=\"http://localhost/api/soap/eyefilm\"><credential>7e8f22c00390b6f1ef7bafe7613cbdd2</credential><snonce>"+         d `tshouldContain` "</snonce><transfermode>34</transfermode><transfermodetimestamp>1356903384</transfermodetimestamp><upsyncallowed>true</upsyncallowed></StartSessionResponse></SOAP-ENV:Body></SOAP-ENV:Envelope>"))
+ test/HEyefi/UploadPhotoSpec.hs view
@@ -0,0 +1,52 @@+module HEyefi.UploadPhotoSpec where++import           Control.Monad+import qualified Data.ByteString.Lazy as BS+import           System.Directory+import           System.Posix.User+import           Test.Hspec+import           System.Posix.Files (+    setOwnerAndGroup+  , fileOwner+  , fileGroup+  , getFileStatus+  )+++import           HEyefi.Config+import           HEyefi.Types+import           HEyefi.UploadPhoto+import           HEyefi.SpecPrelude+++uploadDir :: FilePath+uploadDir = "test_upload_dir"++uploadConfig :: Config+uploadConfig = emptyConfig { uploadDirectory = uploadDir }++removeUploadDir :: IO ()+removeUploadDir = do+  pathExists <- doesPathExist uploadDir+  when pathExists+    (removeDirectoryRecursive uploadDir)++spec :: Spec+spec =+  describe "writeTarFile"+    (it "should write the file to the upload_dir" (+        do+          bs <- BS.readFile "test_upload_file.tar"+          removeUploadDir+          createDirectory uploadDir+          ge <- getGroupEntryForName "wheel"+          ue <- getUserEntryForName "ryantm"+          setOwnerAndGroup uploadDir (userID ue) (groupID ge)+          _ <- runWithConfig uploadConfig (writeTarFile bs)+          contents <- getDirectoryContents uploadDir+          length contents `shouldBe` 3+          let f = "test_upload_dir/test_upload_file.txt"+          fs <- getFileStatus f+          fileGroup fs `shouldBe` groupID ge+          fileOwner fs `shouldBe` userID ue+          removeUploadDir))