diff --git a/heyefi.cabal b/heyefi.cabal --- a/heyefi.cabal +++ b/heyefi.cabal @@ -1,5 +1,5 @@ name: heyefi -version: 0.1.1.1 +version: 1.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. homepage: https://github.com/ryantm/heyefi @@ -19,15 +19,15 @@ default-language: Haskell2010 hs-source-dirs: src main-is: HEyefi/Main.hs - other-modules: HEyefi.Constant + other-modules: HEyefi.App + , HEyefi.Constant , HEyefi.Config , HEyefi.Hex , HEyefi.Log , HEyefi.Soap + , HEyefi.SoapResponse , HEyefi.Types - , HEyefi.MarkLastPhotoInRoll , HEyefi.UploadPhoto - , HEyefi.GetPhotoStatus , HEyefi.StartSession , HEyefi.Strings , HEyefi.CommandLineOptions @@ -71,6 +71,7 @@ , unix , containers , hspec + , hspec-wai , MissingH , bytestring , utf8-string @@ -78,6 +79,7 @@ , iso8601-time , warp , wai + , wai-extra , http-types , HandsomeSoup , hxt diff --git a/src/HEyefi/App.hs b/src/HEyefi/App.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/App.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HEyefi.App where + +import HEyefi.Config (runWithConfig) +import HEyefi.Log (logDebug) +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 + , pathInfo + , 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)) + dispatchRequest (BL.fromStrict body) req f) + atomically (writeTVar sharedConfig config') + return result + +dispatchRequest :: BL.ByteString -> HEyefiApplication +dispatchRequest body req f + | requestMethod req == "POST" && + pathInfo req == ["api","soap","eyefilm","v1","upload"] && + isNothing (soapAction req) = + handleUpload body req f +dispatchRequest body req f + | requestMethod req == "POST" && + isJust (soapAction req) = + handleSoapAction (fromJust (soapAction req)) body req f +dispatchRequest _ _ _ = error didNotMatchDispatch + +getWholeRequestBody :: Request -> IO B.ByteString +getWholeRequestBody request = do + r <- requestBody request + if r == B.empty + then return B.empty + else do + rest <- getWholeRequestBody request + return (B.append r rest) diff --git a/src/HEyefi/Config.hs b/src/HEyefi/Config.hs --- a/src/HEyefi/Config.hs +++ b/src/HEyefi/Config.hs @@ -2,12 +2,30 @@ module HEyefi.Config where -import HEyefi.Types (Config(..), CardConfig, SharedConfig, LogLevel(Info), cardMap, uploadDirectory, logLevel, HEyefiM(..)) +import HEyefi.Types ( + Config(..) + , CardConfig + , SharedConfig + , LogLevel(Info) + , cardMap + , uploadDirectory + , logLevel + , HEyefiM(..)) import HEyefi.Log (logInfo) import HEyefi.Strings -import Control.Concurrent.STM (TVar, readTVar, newTVar, writeTVar, atomically, retry) -import Control.Monad.Catch (finally, catches, Handler (..), SomeException (..)) +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) diff --git a/src/HEyefi/GetPhotoStatus.hs b/src/HEyefi/GetPhotoStatus.hs deleted file mode 100644 --- a/src/HEyefi/GetPhotoStatus.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# 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/Log.hs b/src/HEyefi/Log.hs --- a/src/HEyefi/Log.hs +++ b/src/HEyefi/Log.hs @@ -19,7 +19,7 @@ logInfoIO = log' Info logInfo :: String -> HEyefiM () -logInfo s = liftIO (log' Info s) +logInfo = liftIO . logInfoIO logDebug :: String -> HEyefiM () logDebug s = do diff --git a/src/HEyefi/Main.hs b/src/HEyefi/Main.hs --- a/src/HEyefi/Main.hs +++ b/src/HEyefi/Main.hs @@ -2,14 +2,13 @@ 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, logDebug) -import HEyefi.Soap (handleSoapAction, soapAction) +import HEyefi.Log (logInfoIO) import HEyefi.Strings -import HEyefi.Types (SharedConfig, HEyefiApplication) -import HEyefi.UploadPhoto (handleUpload) +import HEyefi.Types (SharedConfig) import Control.Concurrent (forkIO) import Control.Concurrent.STM ( @@ -18,70 +17,39 @@ , writeTVar , TVar , readTVar ) -import Control.Monad (forever) -import qualified Data.ByteString as B -import Data.ByteString.Lazy (fromStrict) -import qualified Data.ByteString.Lazy as BL -import Data.Maybe (isJust, fromJust, isNothing) -import Network.Wai ( - Application - , Request - , pathInfo - , requestBody - , requestMethod - , requestHeaders ) +import Control.Monad (forever, void) import Network.Wai.Handler.Warp (run) import System.Posix.Signals (installHandler, sigHUP, Handler( Catch )) + handleHup :: TVar (Maybe Int) -> IO () handleHup wakeSig = atomically (writeTVar wakeSig (Just 1)) +hangupSignal :: IO (TVar (Maybe Int)) +hangupSignal = do + wakeSig <- atomically (newTVar Nothing) + _ <- installHandler sigHUP (Catch (handleHup wakeSig)) Nothing + return wakeSig + +readAndMonitorSharedConfig :: TVar (Maybe Int) -> + SharedConfig -> + IO () +readAndMonitorSharedConfig wakeSig sharedConfig = + void (forkIO (forever + (do + c <- atomically (readTVar sharedConfig) + runWithConfig c ( + monitorConfig configPath sharedConfig wakeSig)))) + runHeyefi :: IO () runHeyefi = do - wakeSig <- atomically (newTVar Nothing) + wakeSig <- hangupSignal sharedConfig <- newConfig - _ <- installHandler sigHUP (Catch $ handleHup wakeSig) Nothing - _ <- forkIO (forever - (do - c <- atomically (readTVar sharedConfig) - runWithConfig c ( - monitorConfig configPath sharedConfig wakeSig))) + readAndMonitorSharedConfig wakeSig sharedConfig logInfoIO (listeningOnPort (show port)) run port (app sharedConfig) main :: IO () main = handleOptionsThenMaybe runHeyefi - -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)) - dispatchRequest (fromStrict body) req f) - atomically (writeTVar sharedConfig config') - return result - -dispatchRequest :: BL.ByteString -> HEyefiApplication -dispatchRequest body req f - | requestMethod req == "POST" && - pathInfo req == ["api","soap","eyefilm","v1","upload"] && - isNothing (soapAction req) = - handleUpload body req f -dispatchRequest body req f - | requestMethod req == "POST" && - isJust (soapAction req) = - handleSoapAction (fromJust (soapAction req)) body req f -dispatchRequest _ _ _ = error didNotMatchDispatch - -getWholeRequestBody :: Request -> IO B.ByteString -getWholeRequestBody request = do - r <- requestBody request - if r == B.empty - then return B.empty - else do - rest <- getWholeRequestBody request - return (B.append r rest) diff --git a/src/HEyefi/MarkLastPhotoInRoll.hs b/src/HEyefi/MarkLastPhotoInRoll.hs deleted file mode 100644 --- a/src/HEyefi/MarkLastPhotoInRoll.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# 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 --- a/src/HEyefi/Soap.hs +++ b/src/HEyefi/Soap.hs @@ -1,78 +1,74 @@ {-# LANGUAGE OverloadedStrings #-} -module HEyefi.Soap - ( handleSoapAction - , soapAction - , mkResponse ) - where +module HEyefi.Soap where import HEyefi.Config (getUploadKeyForMacaddress) -import HEyefi.GetPhotoStatus (getPhotoStatusResponse) import HEyefi.Hex (unhex) import HEyefi.Log (logInfo, logDebug) -import HEyefi.MarkLastPhotoInRoll (markLastPhotoInRollResponse) +import HEyefi.SoapResponse ( + markLastPhotoInRollResponse + , getPhotoStatusResponse ) import HEyefi.StartSession (startSessionResponse) import HEyefi.Strings -import HEyefi.Types (HEyefiM, HEyefiApplication, lastSNonce) +import HEyefi.Types -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL - import Control.Arrow ((>>>)) -import Control.Arrow.IOStateListArrow (IOSLA) -import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) import Control.Monad.State.Lazy (get) +import qualified Data.ByteString as B import Data.ByteString.Lazy (fromStrict) +import qualified Data.ByteString.Lazy as BL 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.Maybe (fromJust, isJust) import Data.Time.Clock (getCurrentTime, UTCTime) -import Data.Time.Format (formatTime, rfc822DateFormat, defaultTimeLocale) -import Data.Tree.NTree.TypeDefs (NTree) +import Data.Time.Format ( + formatTime + , rfc822DateFormat + , defaultTimeLocale ) import Network.HTTP.Types (status200, unauthorized401) import Network.HTTP.Types.Header ( - hContentType, - hServer, - hContentLength, - hDate, - Header, - HeaderName ) + hContentType + , hServer + , hContentLength + , hDate + , Header + , HeaderName ) import Network.Wai ( responseLBS , Request , Response , requestHeaders ) import Text.HandsomeSoup (css) -import Text.XML.HXT.Arrow.XmlState.TypeDefs (XIOState) import Text.XML.HXT.Core ( - runX - , readString - , getText - , (/>) ) -import Text.XML.HXT.DOM.TypeDefs (XNode, XmlTree) + getText + , (/>) + , runLA + , xreadDoc ) +soapActionHeaderName :: HeaderName +soapActionHeaderName = CI.mk "SoapAction" -data SoapAction = StartSession - | GetPhotoStatus - | MarkLastPhotoInRoll - deriving (Show, Eq) +headerToSoapAction :: Header -> Maybe SoapAction +headerToSoapAction h | + h == (soapActionHeaderName, "\"urn:StartSession\"") = Just StartSession +headerToSoapAction h | + h == (soapActionHeaderName, "\"urn:GetPhotoStatus\"") = Just GetPhotoStatus +headerToSoapAction h | + h == (soapActionHeaderName, "\"urn:MarkLastPhotoInRoll\"") = + Just MarkLastPhotoInRoll +headerToSoapAction _ = Nothing -headerIsSoapAction :: Header -> Bool -headerIsSoapAction ("SOAPAction",_) = True -headerIsSoapAction _ = False +firstJust :: (a -> Maybe b) -> [a] -> Maybe b +firstJust f = join . find isJust . map f 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 (notADefinedSoapAction (show sa)) - _ -> Nothing +soapAction req = firstJust headerToSoapAction (requestHeaders req) mkResponse :: String -> HEyefiM Response mkResponse responseBody = do @@ -95,31 +91,27 @@ , (hServer, "Eye-Fi Agent/2.0.4.0 (Windows XP SP2)") , (hContentLength, fromString (show size))] - -getTagText :: Control.Monad.IO.Class.MonadIO m => - Control.Arrow.IOStateListArrow.IOSLA - (Text.XML.HXT.Arrow.XmlState.TypeDefs.XIOState ()) - Text.XML.HXT.DOM.TypeDefs.XmlTree - (Data.Tree.NTree.TypeDefs.NTree Text.XML.HXT.DOM.TypeDefs.XNode) - -> String - -> m [String] -getTagText xmlDocument s = liftIO (runX (xmlDocument >>> css s /> getText)) +firstTag :: BL.ByteString -> + String -> + String +firstTag body tagName = + head (runLA (xreadDoc >>> css tagName /> getText) (toString body)) handleSoapAction :: SoapAction -> BL.ByteString -> HEyefiApplication handleSoapAction StartSession body _ f = do logDebug gotStartSessionRequest - let xmlDocument = readString [] (toString body) - macaddress <- getTagText xmlDocument "macaddress" - cnonce <- getTagText xmlDocument "cnonce" - transfermode <- getTagText xmlDocument "transfermode" - transfermodetimestamp <- getTagText xmlDocument "transfermodetimestamp" + let tag = firstTag body + let macaddress = tag "macaddress" + let cnonce = tag "cnonce" + let transfermode = tag "transfermode" + let transfermodetimestamp = tag "transfermodetimestamp" logDebug (show macaddress) logDebug (show transfermodetimestamp) responseBody <- startSessionResponse - (head macaddress) - (head cnonce) - (head transfermode) - (head transfermodetimestamp) + macaddress + cnonce + transfermode + transfermodetimestamp logDebug (show responseBody) response <- mkResponse responseBody liftIO (f response) @@ -127,36 +119,33 @@ logDebug gotGetPhotoStatusRequest credentialGood <- checkCredential body if credentialGood then do - responseBody <- getPhotoStatusResponse - response <- mkResponse responseBody + response <- mkResponse getPhotoStatusResponse liftIO (f response) else liftIO (f mkUnauthorizedResponse) handleSoapAction MarkLastPhotoInRoll _ _ f = do logDebug gotMarkLastPhotoInRollRequest - responseBody <- markLastPhotoInRollResponse - response <- mkResponse responseBody + response <- mkResponse markLastPhotoInRollResponse liftIO (f response) - checkCredential :: BL.ByteString -> HEyefiM Bool checkCredential body = do - let xmlDocument = readString [] (toString body) - macaddress <- getTagText xmlDocument "macaddress" - credential <- getTagText xmlDocument "credential" + let tag = firstTag body + let macaddress = tag "macaddress" + let credential = tag "credential" state <- get let snonce = lastSNonce state - upload_key_0 <- getUploadKeyForMacaddress (head macaddress) + upload_key_0 <- getUploadKeyForMacaddress macaddress case upload_key_0 of Nothing -> do - logInfo (noUploadKeyInConfiguration (head macaddress)) + logInfo (noUploadKeyInConfiguration macaddress) return False Just upload_key_0' -> do - let credentialString = head macaddress ++ upload_key_0' ++ snonce + let credentialString = macaddress ++ upload_key_0' ++ snonce let binaryCredentialString = unhex credentialString let expectedCredential = md5s (Str (fromJust binaryCredentialString)) - if head credential /= expectedCredential then do - logInfo (invalidCredential expectedCredential (head credential)) + if credential /= expectedCredential then do + logInfo (invalidCredential expectedCredential credential) return False else return True diff --git a/src/HEyefi/SoapResponse.hs b/src/HEyefi/SoapResponse.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/SoapResponse.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HEyefi.SoapResponse where + +import Control.Arrow ((>>>)) +import Text.XML.HXT.Core ( + runLA + , root + , writeDocumentToString + , XmlTree + , LA + , mkelem + , spi + , sattr + , t_xml + , ArrowXml + , mkelem + , sattr + , LA + , XmlTree + , txt ) + +soapMessage :: ArrowXml a => [a n XmlTree] -> [a n XmlTree] +soapMessage body = + [ 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" [] body ]] + +soapResponse :: [LA n XmlTree] -> String +soapResponse body = + head (runLA (document >>> writeDocumentToString []) undefined) + where + document = root [] (soapMessage body) + +uploadPhotoResponse :: [LA n XmlTree] +uploadPhotoResponse = + [ mkelem "UploadPhotoResponse" + [ sattr "xmlns" "http://localhost/api/soap/eyefilm" ] + [ mkelem "success" [] [ txt "true" ] ] + ] + +markLastPhotoInRollResponse :: String +markLastPhotoInRollResponse = soapResponse markLastPhotoInRollBody + +markLastPhotoInRollBody :: [LA n XmlTree] +markLastPhotoInRollBody = + [ mkelem "MarkLastPhotoInRollResponse" + [ sattr "xmlns" "http://localhost/api/soap/eyefilm" ] + [] + ] + +getPhotoStatusResponse :: String +getPhotoStatusResponse = soapResponse getPhotoStatusBody + +getPhotoStatusBody :: [LA n XmlTree] +getPhotoStatusBody = + [ mkelem "GetPhotoStatusResponse" + [ sattr "xmlns" "http://localhost/api/soap/eyefilm" ] + [ mkelem "fileid" [] [ txt "1" ] + , mkelem "offset" [] [ txt "0" ] + ] + ] diff --git a/src/HEyefi/StartSession.hs b/src/HEyefi/StartSession.hs --- a/src/HEyefi/StartSession.hs +++ b/src/HEyefi/StartSession.hs @@ -14,7 +14,7 @@ import Data.Hash.MD5 (md5s, Str (..)) import Data.Maybe (fromJust) import System.Random (randomRIO) -import Text.XML.HXT.Core ( runX +import Text.XML.HXT.Core ( runLA , mkelem , spi , t_xml @@ -63,5 +63,5 @@ ] ] ] - result <- liftIO (runX (document >>> writeDocumentToString [])) - return (head result) + + return (head (runLA (document >>> writeDocumentToString []) undefined)) diff --git a/src/HEyefi/Strings.hs b/src/HEyefi/Strings.hs --- a/src/HEyefi/Strings.hs +++ b/src/HEyefi/Strings.hs @@ -64,3 +64,9 @@ programHeaderDescription :: String programHeaderDescription = "heyefi - a server for Eye-Fi SD cards" + +gotUploadRequest :: String +gotUploadRequest = "Got Upload request" + +uploadedTo :: String -> String +uploadedTo = (++) "Uploaded to " diff --git a/src/HEyefi/Types.hs b/src/HEyefi/Types.hs --- a/src/HEyefi/Types.hs +++ b/src/HEyefi/Types.hs @@ -45,3 +45,8 @@ } type SharedConfig = TVar Config + +data SoapAction = StartSession + | GetPhotoStatus + | MarkLastPhotoInRoll + deriving (Show, Eq) diff --git a/src/HEyefi/UploadPhoto.hs b/src/HEyefi/UploadPhoto.hs --- a/src/HEyefi/UploadPhoto.hs +++ b/src/HEyefi/UploadPhoto.hs @@ -5,32 +5,34 @@ import HEyefi.Constant (multipartBodyBoundary) import HEyefi.Log (logDebug, logInfo) 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.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 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) +import System.Posix.Files ( + setOwnerAndGroup + , fileOwner + , fileGroup + , getFileStatus + , FileStatus ) + copyMatchingOwnership :: FileStatus -> FilePath -> FilePath -> IO FilePath copyMatchingOwnership fs from to = do - setOwnerAndGroup from (fileOwner fs) (fileGroup fs) copyFile from to + setOwnerAndGroup to (fileOwner fs) (fileGroup fs) return to changeOwnershipAndCopy :: FilePath -> FilePath -> IO FilePath @@ -44,24 +46,6 @@ 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 @@ -80,7 +64,7 @@ handleUpload :: BL.ByteString -> HEyefiApplication handleUpload body _ f = do - logInfo "Got Upload request" + logDebug gotUploadRequest let MultiPart bodyParts = parseMultipartBody multipartBodyBoundary body logDebug (show (length bodyParts)) lBP bodyParts @@ -89,11 +73,11 @@ let (BodyPart _ digest) = bodyParts !! 2 outputPath <- writeTarFile file - logInfo ("Uploaded to " ++ outputPath) + logInfo (uploadedTo outputPath) logDebug (show soapEnvelope) logDebug (show digest) - responseBody <- uploadPhotoResponse + let responseBody = soapResponse uploadPhotoResponse logDebug (show responseBody) r <- mkResponse responseBody liftIO (f r)