packages feed

heyefi 0.1.0.0 → 0.1.0.1

raw patch · 12 files changed

+681/−2 lines, 12 filesdep ~base

Dependency ranges changed: base

Files

heyefi.cabal view
@@ -1,5 +1,5 @@ name:                heyefi-version:             0.1.0.0+version:             0.1.0.1 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. homepage:            https://github.com/ryantm/heyefi@@ -19,6 +19,16 @@   default-language:    Haskell2010   hs-source-dirs:      src   main-is:             HEyefi/Main.hs+  other-modules:       HEyefi.Constant+                     , HEyefi.Config+                     , HEyefi.Hex+                     , HEyefi.Log+                     , HEyefi.Soap+                     , HEyefi.Types+                     , HEyefi.MarkLastPhotoInRoll+                     , HEyefi.UploadPhoto+                     , HEyefi.GetPhotoStatus+                     , HEyefi.StartSession   ghc-options:         -Wall   build-depends:       base >=4 && <=5                      , stm
+ src/HEyefi/Config.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedStrings #-}++module HEyefi.Config where++import           HEyefi.Types (Config(..), CardConfig, SharedConfig, LogLevel(Info), cardMap, uploadDirectory, logLevel, HEyefiM(..))+import           HEyefi.Log (logInfo)+import           HEyefi.Constant hiding (configPath)++import           Control.Concurrent.STM (TVar, readTVar, newTVar, writeTVar, atomically, retry)+import           Control.Monad.Catch (finally, catches, Handler (..), SomeException (..))+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.State.Lazy (get, put, 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)++insertCard :: Text -> Text -> Config -> Config+insertCard macAddress uploadKey c = do+  Config {+    cardMap = HM.insert macAddress uploadKey (cardMap c),+    uploadDirectory = uploadDirectory c,+    logLevel = logLevel c,+    lastSNonce = lastSNonce c+    }+++waitForWake :: TVar (Maybe Int) -> HEyefiM ()+waitForWake wakeSig = liftIO (atomically (+  do state <- readTVar wakeSig+     case state of+      Just _ -> writeTVar wakeSig Nothing+      Nothing -> retry))++convertCardList :: Value -> Either String [(Text, Text)]+convertCardList (CT.List innerList) =+  Right (mapMaybe extractTuple innerList)+  where+    extractTuple :: Value -> Maybe (Text, Text)+    extractTuple (CT.List [CT.String macAddress, CT.String key]) =+      Just (macAddress, key)+    extractTuple _ = Nothing+convertCardList _ = Left cardsFormatDoesNotMatch++getCardConfig :: HM.HashMap CT.Name CT.Value -> HEyefiM CardConfig+getCardConfig configMap = do+  let cards = HM.lookup "cards" configMap+  case cards of+   Nothing -> do+     logInfo missingCardsDefinition+     return HM.empty+   Just l -> do+     case convertCardList l of+      Left msg -> do+        logInfo msg+        return HM.empty+      Right cardList ->+        return (HM.fromList cardList)++convertUploadDirectory :: Value -> Either String FilePath+convertUploadDirectory (CT.String uploadDir) =+  Right (unpack uploadDir)+convertUploadDirectory _ =+  Left uploadDirFormatDoesNotMatch++getUploadDirectory :: HM.HashMap CT.Name CT.Value -> HEyefiM FilePath+getUploadDirectory configMap = do+  let uploadDir = HM.lookup "upload_dir" configMap+  case uploadDir of+   Nothing -> do+     logInfo missingUploadDirDefinition+     return ""+   Just uD -> do+     case convertUploadDirectory uD of+      Left msg -> do+        logInfo msg+        return ""+      Right path ->+        return path++reloadConfig :: FilePath -> HEyefiM Config+reloadConfig configPath = do+  logInfo ("Trying to load configuration at " ++ configPath)+  catches (+    do+      config <- liftIO (load [Required configPath])+      configMap <- liftIO (getMap config)+      cardConfig <- getCardConfig configMap+      uploadDir <- getUploadDirectory configMap+      logInfo "Loaded configuration"+      return Config {+        cardMap = cardConfig,+        uploadDirectory = uploadDir,+        logLevel = Info,+        lastSNonce = "" } -- TODO: Careful, we might be erasing something here.+    )+    [Handler (\(ParseError p msg) -> do+                 logInfo+                   ("Error parsing configuration file at " +++                          p +++                          " with message: " +++                          msg)+                 return emptyConfig),+     Handler (\(SomeException _) -> do+                 logInfo+                   ("Could not find configuration file at " ++ configPath)+                 return emptyConfig)]++runWithConfig :: Config -> HEyefiM a -> IO (a,Config)+runWithConfig c m = runStateT (runHeyefi m) c++runWithEmptyConfig :: HEyefiM a -> IO (a,Config)+runWithEmptyConfig = runWithConfig emptyConfig++emptyConfig :: Config+emptyConfig = Config { cardMap = HM.empty+                     , uploadDirectory = ""+                     , logLevel = Info+                     , lastSNonce = ""}++newConfig :: IO SharedConfig+newConfig = atomically (newTVar emptyConfig)++-- Example config:+-- cards = [["0012342de4ce","e7403a0123402ca062"],["1234562d5678","12342a062"]]+-- upload_dir = "/data/annex/doxie/unsorted"+monitorConfig :: FilePath -> SharedConfig -> TVar (Maybe Int) -> HEyefiM ()+monitorConfig configPath sharedConfig wakeSignal =+  finally+    (do+        config <- reloadConfig configPath+        liftIO (atomically (writeTVar sharedConfig config)))+    (waitForWake wakeSignal)++getUploadKeyForMacaddress :: String -> HEyefiM (Maybe String)+getUploadKeyForMacaddress mac = do+  c <- get+  return (fmap unpack (HM.lookup (pack mac) (cardMap c)))++putSNonce :: String -> HEyefiM ()+putSNonce snonce = do+  c <- get+  put (Config {+          cardMap = cardMap c,+          uploadDirectory = uploadDirectory c,+          logLevel = logLevel c,+          lastSNonce = snonce+          })
+ src/HEyefi/Constant.hs view
@@ -0,0 +1,27 @@+module HEyefi.Constant where++port :: Int+port = 59278++configPath :: String+configPath = "/etc/heyefi/heyefi.config"++multipartBodyBoundary :: String+multipartBodyBoundary =+  "---------------------------02468ace13579bdfcafebabef00d"++-- Messages+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`."
+ src/HEyefi/GetPhotoStatus.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}++module HEyefi.GetPhotoStatus where++import HEyefi.Types (HEyefiM)++import Control.Arrow ((>>>))+import Control.Monad.IO.Class (liftIO)+import Text.XML.HXT.Core ( runX+                         , mkelem+                         , spi+                         , t_xml+                         , sattr+                         , txt+                         , root+                         , writeDocumentToString)++getPhotoStatusResponse :: HEyefiM String+getPhotoStatusResponse = do+  let document =+        root []+        [ spi t_xml "version=\"1.0\" encoding=\"UTF-8\""+        , mkelem "SOAP-ENV:Envelope"+          [ sattr "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" ]+          [ mkelem "SOAP-ENV:Body" []+            [ mkelem "GetPhotoStatusResponse"+              [ sattr "xmlns" "http://localhost/api/soap/eyefilm" ]+              [ mkelem "fileid" [] [ txt "1" ]+              , mkelem "offset" [] [ txt "0" ]+              ]+            ]+          ]+        ]+  result <- liftIO (runX (document >>> writeDocumentToString []))+  return (head result)
+ src/HEyefi/Hex.hs view
@@ -0,0 +1,35 @@+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++c :: Char -> Maybe Int+c '0' = Just 0+c '1' = Just 1+c '2' = Just 2+c '3' = Just 3+c '4' = Just 4+c '5' = Just 5+c '6' = Just 6+c '7' = Just 7+c '8' = Just 8+c '9' = Just 9+c 'a' = Just 10+c 'b' = Just 11+c 'c' = Just 12+c 'd' = Just 13+c 'e' = Just 14+c 'f' = Just 15+c 'A' = Just 10+c 'B' = Just 11+c 'C' = Just 12+c 'D' = Just 13+c 'E' = Just 14+c 'F' = Just 15+c _   = Nothing
+ src/HEyefi/Log.hs view
@@ -0,0 +1,30 @@+module HEyefi.Log where++import HEyefi.Types (HEyefiM, LogLevel(..), logLevel)++import Control.Monad.IO.Class (liftIO)+import Control.Monad.State.Lazy (get)+import Data.Time.Clock (getCurrentTime)+import Data.Time.ISO8601 (formatISO8601Millis)++log' :: LogLevel -> String -> IO ()+log' ll s = do+  t <- getCurrentTime+  putStrLn (unwords [+                 "[" ++ formatISO8601Millis t ++ "]"+               , "[" ++ show ll ++ "]"+               , s])++logInfoIO :: String -> IO ()+logInfoIO s = log' Info s++logInfo ::  String -> HEyefiM ()+logInfo s = liftIO (log' Info s)++logDebug :: String -> HEyefiM ()+logDebug s = do+  config <- get+  let ll = logLevel config+  case ll of+   Debug -> liftIO (log' Debug s)+   _ -> return ()
src/HEyefi/Main.hs view
@@ -11,7 +11,8 @@   import           Control.Concurrent (forkIO)-import           Control.Concurrent.STM (newTVar, atomically, writeTVar, TVar, readTVar)+import           Control.Concurrent.STM (+  newTVar, atomically, writeTVar, TVar, readTVar ) import           Control.Monad (forever) import qualified Data.ByteString as B import           Data.ByteString.Lazy (fromStrict)
+ src/HEyefi/MarkLastPhotoInRoll.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}++module HEyefi.MarkLastPhotoInRoll where++import HEyefi.Types (HEyefiM)++import Control.Arrow ((>>>))+import Control.Monad.IO.Class (liftIO)+import Text.XML.HXT.Core ( runX+                         , mkelem+                         , spi+                         , t_xml+                         , sattr+                         , root+                         , writeDocumentToString)++markLastPhotoInRollResponse :: HEyefiM String+markLastPhotoInRollResponse = do+  let document =+        root []+        [ spi t_xml "version=\"1.0\" encoding=\"UTF-8\""+        , mkelem "SOAP-ENV:Envelope"+          [ sattr "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" ]+          [ mkelem "SOAP-ENV:Body" []+            [ mkelem "MarkLastPhotoInRollResponse"+              [ sattr "xmlns" "http://localhost/api/soap/eyefilm" ]+              []+            ]+          ]+        ]+  result <- liftIO (runX (document >>> writeDocumentToString []))+  return (head result)
+ src/HEyefi/Soap.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE OverloadedStrings #-}++module HEyefi.Soap+       ( handleSoapAction+       , soapAction+       , mkResponse )+       where++import           HEyefi.Config (getUploadKeyForMacaddress)+import           HEyefi.GetPhotoStatus (getPhotoStatusResponse)+import           HEyefi.Hex (unhex)+import           HEyefi.Log (logInfo, logDebug)+import           HEyefi.MarkLastPhotoInRoll (markLastPhotoInRollResponse)+import           HEyefi.StartSession (startSessionResponse)+import           HEyefi.Types (HEyefiM, HEyefiApplication, lastSNonce)+++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++import           Control.Arrow ((>>>))+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.State.Lazy (get)+import           Data.ByteString.Lazy (fromStrict)+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)+import           Data.Time.Clock (getCurrentTime, UTCTime)+import           Data.Time.Format (formatTime, rfc822DateFormat, defaultTimeLocale)+import           Network.HTTP.Types (status200, unauthorized401)+import Network.HTTP.Types.Header (hContentType,+                                  hServer,+                                  hContentLength,+                                  hDate,+                                  Header,+                                  HeaderName)+import Network.Wai ( responseLBS+                   , Request+                   , Response+                   , requestHeaders )+import           Text.HandsomeSoup (css)+import Text.XML.HXT.Core ( runX+                         , readString+                         , getText+                         , (/>))+++data SoapAction = StartSession+                | GetPhotoStatus+                | MarkLastPhotoInRoll+                deriving (Show, Eq)++headerIsSoapAction :: Header -> Bool+headerIsSoapAction ("SOAPAction",_) = True+headerIsSoapAction _ = False++soapAction :: Request -> Maybe SoapAction+soapAction req =+  case find headerIsSoapAction (requestHeaders req) of+   Just (_,"\"urn:StartSession\"") -> Just StartSession+   Just (_,"\"urn:GetPhotoStatus\"") -> Just GetPhotoStatus+   Just (_,"\"urn:MarkLastPhotoInRoll\"") -> Just MarkLastPhotoInRoll+   Just (_,sa) -> error ((show sa) ++ " is not a defined SoapAction yet")+   _ -> Nothing++mkResponse :: String -> HEyefiM Response+mkResponse responseBody = do+  t <- liftIO getCurrentTime+  return (responseLBS+          status200+          (defaultResponseHeaders t (length responseBody))+          (fromStrict (fromString responseBody)))++mkUnauthorizedResponse :: Response+mkUnauthorizedResponse = responseLBS unauthorized401 [] ""++defaultResponseHeaders :: UTCTime ->+                          Int ->+                          [(HeaderName, B.ByteString)]+defaultResponseHeaders time size =+  [ (hContentType, "text/xml; charset=\"utf-8\"")+  , (hDate, fromString (formatTime defaultTimeLocale rfc822DateFormat time))+  , (CI.mk "Pragma", "no-cache")+  , (hServer, "Eye-Fi Agent/2.0.4.0 (Windows XP SP2)")+  , (hContentLength, fromString (show size))]++handleSoapAction :: SoapAction -> BL.ByteString -> HEyefiApplication+handleSoapAction StartSession body _ f = do+  logInfo "Got StartSession request"+  let xmlDocument = readString [] (toString body)+  let getTagText = \ s -> liftIO (runX (xmlDocument >>> css s /> getText))+  macaddress <- getTagText "macaddress"+  cnonce <- getTagText "cnonce"+  transfermode <- getTagText "transfermode"+  transfermodetimestamp <- getTagText "transfermodetimestamp"+  logDebug (show macaddress)+  logDebug (show transfermodetimestamp)+  responseBody <- (startSessionResponse+                   (head macaddress)+                   (head cnonce)+                   (head transfermode)+                   (head transfermodetimestamp))+  logDebug (show responseBody)+  response <- mkResponse responseBody+  liftIO (f response)+handleSoapAction GetPhotoStatus body _ f = do+  logInfo "Got GetPhotoStatus request"+  credentialGood <- checkCredential body+  if credentialGood then do+    responseBody <- getPhotoStatusResponse+    response <- mkResponse responseBody+    liftIO (f response)+  else do+    liftIO (f mkUnauthorizedResponse)+handleSoapAction MarkLastPhotoInRoll _ _ f = do+  logInfo "Got MarkLastPhotoInRoll request"+  responseBody <- markLastPhotoInRollResponse+  response <- mkResponse responseBody+  liftIO (f response)+++checkCredential :: BL.ByteString -> HEyefiM Bool+checkCredential body = do+  let xmlDocument = readString [] (toString body)+  let getTagText = \ s -> liftIO (runX (xmlDocument >>> css s /> getText))+  macaddress <- getTagText "macaddress"+  credential <- getTagText "credential"+  state <- get+  let snonce = lastSNonce state+  upload_key_0 <- getUploadKeyForMacaddress (head macaddress)+  case upload_key_0 of+   Nothing -> do+     logInfo ("No upload key found in configuration for macaddress: " ++ (head macaddress))+     return False+   Just upload_key_0' -> do+     let credentialString = (head macaddress) ++ upload_key_0' ++ snonce+     let binaryCredentialString = unhex credentialString+     let expectedCredential = md5s (Str (fromJust binaryCredentialString))+     if ((head credential) /= expectedCredential) then do+       logInfo ("Invalid credential in GetPhotoStatus request. Expected: "+                ++ expectedCredential ++ " Actual: " ++ (head credential))+       return False+     else+       return True
+ src/HEyefi/StartSession.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}++module HEyefi.StartSession where++import HEyefi.Config (getUploadKeyForMacaddress, putSNonce)+import HEyefi.Hex (unhex)+import HEyefi.Log (logInfo)+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 Text.XML.HXT.Core ( runX+                         , mkelem+                         , spi+                         , t_xml+                         , sattr+                         , txt+                         , root+                         , writeDocumentToString)++newServerNonce :: IO String+newServerNonce =+  replicateM 32 (do+                    i <- randomRIO (0, 15)+                    return (intToDigit i))++startSessionResponse :: String ->+                        String ->+                        String ->+                        String ->+                        HEyefiM String+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)+     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 document =+           root []+           [ spi t_xml "version=\"1.0\" encoding=\"UTF-8\""+           , mkelem "SOAP-ENV:Envelope"+             [ sattr "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" ]+             [ 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 "upsyncallowed" [] [ txt "true" ]+                 ]+               ]+             ]+           ]+     result <- liftIO (runX (document >>> writeDocumentToString []))+     return (head result)
+ src/HEyefi/Types.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module HEyefi.Types where++import           Control.Concurrent.STM (TVar)+import           Control.Monad.Catch (MonadMask, MonadCatch, MonadThrow)+import           Control.Monad.IO.Class (MonadIO)+import           Control.Monad.State.Lazy (StateT)+import           Control.Monad.State.Class (MonadState)+import qualified Data.HashMap.Strict as HM+import           Data.Text (Text)+import           Network.Wai (Request, Response, ResponseReceived)++--Global Monads+newtype HEyefiM a = HEyefiM {+  runHeyefi :: StateT Config IO a+  } deriving (Functor, Applicative, Monad, MonadIO, MonadMask, MonadCatch, MonadThrow, MonadState Config)++type HEyefiApplication = Request -> (Response -> IO ResponseReceived) -> HEyefiM ResponseReceived++-- Logging+data LogLevel = Info | Debug+              deriving (Eq, Show)++-- Configuration+type MacAddress = Text+type UploadKey = Text++type CardConfig = HM.HashMap MacAddress UploadKey++data Config = Config {+  cardMap :: CardConfig,+  uploadDirectory :: FilePath,+  logLevel :: LogLevel,+  lastSNonce :: String+}++type SharedConfig = TVar Config
+ src/HEyefi/UploadPhoto.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}++module HEyefi.UploadPhoto where++import           HEyefi.Constant (multipartBodyBoundary)+import           HEyefi.Log (logDebug, logInfo)+import           HEyefi.Soap (mkResponse)+import           HEyefi.Types (uploadDirectory, HEyefiM, HEyefiApplication)++import           Codec.Archive.Tar (extract)+import           Control.Arrow ((>>>))+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.State.Lazy (get)+import qualified Data.ByteString.Lazy as BL+import           Network.Multipart ( parseMultipartBody, MultiPart (..), BodyPart (..) )+import           System.Directory (copyFile, getDirectoryContents)+import           System.FilePath.Posix ((</>))+import           System.IO (hClose)+import           System.IO.Temp (withSystemTempFile, withSystemTempDirectory)+import           System.Posix.Files (setOwnerAndGroup, fileOwner, fileGroup, getFileStatus, FileStatus)+import Text.XML.HXT.Core ( runX+                         , mkelem+                         , spi+                         , t_xml+                         , sattr+                         , txt+                         , root+                         , writeDocumentToString)++copyMatchingOwnership :: FileStatus -> FilePath -> FilePath -> IO (FilePath)+copyMatchingOwnership fs from to = do+  setOwnerAndGroup from (fileOwner fs) (fileGroup fs)+  copyFile from to+  return to++changeOwnershipAndCopy :: FilePath -> FilePath -> IO (FilePath)+changeOwnershipAndCopy uploadDir extractionDir = do+  s <- getFileStatus uploadDir+  names <- getDirectoryContents extractionDir+  paths <- mapM (processName s) (properNames names)+  return (head paths)+  where+    properNames = filter (`notElem` [".", ".."])+    processName s n =+      copyMatchingOwnership s (extractionDir </> n) (uploadDir </> n)++uploadPhotoResponse :: HEyefiM String+uploadPhotoResponse = do+  let document =+        root [ ]+        [ spi t_xml "version=\"1.0\" encoding=\"UTF-8\""+        , mkelem "SOAP-ENV:Envelope"+          [ sattr "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" ]+          [ mkelem "SOAP-ENV:Body" []+            [ mkelem "UploadPhotoResponse"+              [ sattr "xmlns" "http://localhost/api/soap/eyefilm" ]+              [ mkelem "success" [] [ txt "true" ]+              ]+            ]+          ]+        ]+  result <- liftIO (runX (document >>> writeDocumentToString []))+  return (head result)++-- TODO: handle case where uploaded file has a bad format+-- TODO: handle case where temp file is not created+writeTarFile :: BL.ByteString -> HEyefiM (FilePath)+writeTarFile file = do+  config <- get+  let uploadDir = uploadDirectory config+  liftIO (withSystemTempFile "heyefi.tar" (handleFile uploadDir))+  where+    handleFile uploadDir filePath handle = do+      withSystemTempDirectory "heyefi_extracted" (handleDir uploadDir filePath handle)+    handleDir uploadDir tempFile tempFileHandle extractionDir = do+      BL.hPut tempFileHandle file+      hClose tempFileHandle+      extract extractionDir tempFile+      changeOwnershipAndCopy uploadDir extractionDir++handleUpload :: BL.ByteString -> HEyefiApplication+handleUpload body _ f = do+  logInfo "Got Upload request"+  let MultiPart bodyParts = parseMultipartBody multipartBodyBoundary body+  logDebug (show (length bodyParts))+  lBP bodyParts+  let (BodyPart _ soapEnvelope) = bodyParts !! 0+  let (BodyPart _ file) = bodyParts !! 1+  let (BodyPart _ digest) = bodyParts !! 2++  outputPath <- writeTarFile file+  logInfo ("Uploaded to " ++ outputPath)++  logDebug (show soapEnvelope)+  logDebug (show digest)+  responseBody <- uploadPhotoResponse+  logDebug (show responseBody)+  r <- mkResponse responseBody+  liftIO (f r)++  where+    lBP [] = return ()+    lBP ((BodyPart headers _):xs) = do+      logDebug (show headers)+      lBP xs+      return ()