diff --git a/heyefi.cabal b/heyefi.cabal --- a/heyefi.cabal +++ b/heyefi.cabal @@ -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 diff --git a/src/HEyefi/Config.hs b/src/HEyefi/Config.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/Config.hs @@ -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 + }) diff --git a/src/HEyefi/Constant.hs b/src/HEyefi/Constant.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/Constant.hs @@ -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`." diff --git a/src/HEyefi/GetPhotoStatus.hs b/src/HEyefi/GetPhotoStatus.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/GetPhotoStatus.hs @@ -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) diff --git a/src/HEyefi/Hex.hs b/src/HEyefi/Hex.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/Hex.hs @@ -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 diff --git a/src/HEyefi/Log.hs b/src/HEyefi/Log.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/Log.hs @@ -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 () diff --git a/src/HEyefi/Main.hs b/src/HEyefi/Main.hs --- a/src/HEyefi/Main.hs +++ b/src/HEyefi/Main.hs @@ -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) diff --git a/src/HEyefi/MarkLastPhotoInRoll.hs b/src/HEyefi/MarkLastPhotoInRoll.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/MarkLastPhotoInRoll.hs @@ -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) diff --git a/src/HEyefi/Soap.hs b/src/HEyefi/Soap.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/Soap.hs @@ -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 diff --git a/src/HEyefi/StartSession.hs b/src/HEyefi/StartSession.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/StartSession.hs @@ -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) diff --git a/src/HEyefi/Types.hs b/src/HEyefi/Types.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/Types.hs @@ -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 diff --git a/src/HEyefi/UploadPhoto.hs b/src/HEyefi/UploadPhoto.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/UploadPhoto.hs @@ -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 ()