heyefi 0.1.1.1 → 1.0.0.0
raw patch · 13 files changed
+264/−239 lines, 13 filesdep +hspec-waidep +wai-extradep ~optparse-applicative
Dependencies added: hspec-wai, wai-extra
Dependency ranges changed: optparse-applicative
Files
- heyefi.cabal +6/−4
- src/HEyefi/App.hs +57/−0
- src/HEyefi/Config.hs +21/−3
- src/HEyefi/GetPhotoStatus.hs +0/−35
- src/HEyefi/Log.hs +1/−1
- src/HEyefi/Main.hs +23/−55
- src/HEyefi/MarkLastPhotoInRoll.hs +0/−32
- src/HEyefi/Soap.hs +62/−73
- src/HEyefi/SoapResponse.hs +63/−0
- src/HEyefi/StartSession.hs +3/−3
- src/HEyefi/Strings.hs +6/−0
- src/HEyefi/Types.hs +5/−0
- src/HEyefi/UploadPhoto.hs +17/−33
heyefi.cabal view
@@ -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
+ src/HEyefi/App.hs view
@@ -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)
src/HEyefi/Config.hs view
@@ -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)
− src/HEyefi/GetPhotoStatus.hs
@@ -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)
src/HEyefi/Log.hs view
@@ -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
src/HEyefi/Main.hs view
@@ -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)
− src/HEyefi/MarkLastPhotoInRoll.hs
@@ -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)
src/HEyefi/Soap.hs view
@@ -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
+ src/HEyefi/SoapResponse.hs view
@@ -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" ]+ ]+ ]
src/HEyefi/StartSession.hs view
@@ -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))
src/HEyefi/Strings.hs view
@@ -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 "
src/HEyefi/Types.hs view
@@ -45,3 +45,8 @@ } type SharedConfig = TVar Config++data SoapAction = StartSession+ | GetPhotoStatus+ | MarkLastPhotoInRoll+ deriving (Show, Eq)
src/HEyefi/UploadPhoto.hs view
@@ -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)