diff --git a/heyefi.cabal b/heyefi.cabal --- a/heyefi.cabal +++ b/heyefi.cabal @@ -1,5 +1,5 @@ name: heyefi -version: 0.1.0.2 +version: 0.1.1.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 @@ -29,6 +29,8 @@ , HEyefi.UploadPhoto , HEyefi.GetPhotoStatus , HEyefi.StartSession + , HEyefi.Strings + , HEyefi.CommandLineOptions ghc-options: -Wall build-depends: base >=4.8 && <=5 , stm @@ -60,6 +62,7 @@ , transformers , exceptions , random + , optparse-applicative test-suite test-heyefi default-language: Haskell2010 @@ -101,3 +104,4 @@ , transformers , exceptions , random + , optparse-applicative diff --git a/src/HEyefi/CommandLineOptions.hs b/src/HEyefi/CommandLineOptions.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/CommandLineOptions.hs @@ -0,0 +1,29 @@ +module HEyefi.CommandLineOptions where + +import HEyefi.Strings + +import Data.Version (showVersion) +import Options.Applicative +import Options.Applicative.Types +import Paths_heyefi (version) + + +opts :: ParserInfo (Maybe ()) +opts = info (helper <*> parser) + ( fullDesc + <> progDesc programDescription + <> header programHeaderDescription ) + +parser :: Parser (Maybe ()) +parser = + flag' Nothing + (long "version" <> short 'v' <> help "Show version") + <|> NilP (Just (Just ())) + +maybeOnlyPrintVersion :: IO () -> Maybe () -> IO () +maybeOnlyPrintVersion _ Nothing = putStrLn ("heyefi " ++ showVersion version) +maybeOnlyPrintVersion continueWith _ = continueWith + +handleOptionsThenMaybe :: IO () -> IO () +handleOptionsThenMaybe continueWith = + execParser opts >>= maybeOnlyPrintVersion continueWith diff --git a/src/HEyefi/Config.hs b/src/HEyefi/Config.hs --- a/src/HEyefi/Config.hs +++ b/src/HEyefi/Config.hs @@ -4,7 +4,7 @@ import HEyefi.Types (Config(..), CardConfig, SharedConfig, LogLevel(Info), cardMap, uploadDirectory, logLevel, HEyefiM(..)) import HEyefi.Log (logInfo) -import HEyefi.Constant hiding (configPath) +import HEyefi.Strings import Control.Concurrent.STM (TVar, readTVar, newTVar, writeTVar, atomically, retry) import Control.Monad.Catch (finally, catches, Handler (..), SomeException (..)) @@ -19,7 +19,7 @@ import Data.Text (Text, unpack, pack) insertCard :: Text -> Text -> Config -> Config -insertCard macAddress uploadKey c = do +insertCard macAddress uploadKey c = Config { cardMap = HM.insert macAddress uploadKey (cardMap c), uploadDirectory = uploadDirectory c, @@ -52,7 +52,7 @@ Nothing -> do logInfo missingCardsDefinition return HM.empty - Just l -> do + Just l -> case convertCardList l of Left msg -> do logInfo msg @@ -73,7 +73,7 @@ Nothing -> do logInfo missingUploadDirDefinition return "" - Just uD -> do + Just uD -> case convertUploadDirectory uD of Left msg -> do logInfo msg @@ -83,14 +83,14 @@ reloadConfig :: FilePath -> HEyefiM Config reloadConfig configPath = do - logInfo ("Trying to load configuration at " ++ configPath) + logInfo (tryingToLoadConfiguration configPath) catches ( do config <- liftIO (load [Required configPath]) configMap <- liftIO (getMap config) cardConfig <- getCardConfig configMap uploadDir <- getUploadDirectory configMap - logInfo "Loaded configuration" + logInfo loadedConfiguration return Config { cardMap = cardConfig, uploadDirectory = uploadDir, @@ -98,15 +98,10 @@ lastSNonce = "" } -- TODO: Careful, we might be erasing something here. ) [Handler (\(ParseError p msg) -> do - logInfo - ("Error parsing configuration file at " ++ - p ++ - " with message: " ++ - msg) + logInfo (errorParsingConfigurationFile p msg) return emptyConfig), Handler (\(SomeException _) -> do - logInfo - ("Could not find configuration file at " ++ configPath) + logInfo (couldNotFindConfigurationFile configPath) return emptyConfig)] runWithConfig :: Config -> HEyefiM a -> IO (a,Config) @@ -143,9 +138,9 @@ putSNonce :: String -> HEyefiM () putSNonce snonce = do c <- get - put (Config { + 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 --- a/src/HEyefi/Constant.hs +++ b/src/HEyefi/Constant.hs @@ -9,19 +9,3 @@ 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/Hex.hs b/src/HEyefi/Hex.hs --- a/src/HEyefi/Hex.hs +++ b/src/HEyefi/Hex.hs @@ -7,7 +7,7 @@ second <- c b rest <- unhex xs return (toEnum ((first * 16) + second) : rest) -unhex [_] = Nothing +unhex _ = Nothing c :: Char -> Maybe Int c '0' = Just 0 diff --git a/src/HEyefi/Log.hs b/src/HEyefi/Log.hs --- a/src/HEyefi/Log.hs +++ b/src/HEyefi/Log.hs @@ -16,7 +16,7 @@ , s]) logInfoIO :: String -> IO () -logInfoIO s = log' Info s +logInfoIO = log' Info logInfo :: String -> HEyefiM () logInfo s = liftIO (log' Info s) @@ -24,7 +24,6 @@ logDebug :: String -> HEyefiM () logDebug s = do config <- get - let ll = logLevel config - case ll of + case logLevel config 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 @@ -2,36 +2,42 @@ module Main where +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.Strings import HEyefi.Types (SharedConfig, HEyefiApplication) import HEyefi.UploadPhoto (handleUpload) - import Control.Concurrent (forkIO) import Control.Concurrent.STM ( - newTVar, atomically, writeTVar, TVar, readTVar ) + newTVar + , atomically + , 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 Network.Wai ( + Application + , Request + , pathInfo + , requestBody + , requestMethod + , requestHeaders ) 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)) -main :: IO () -main = do +runHeyefi :: IO () +runHeyefi = do wakeSig <- atomically (newTVar Nothing) sharedConfig <- newConfig _ <- installHandler sigHUP (Catch $ handleHup wakeSig) Nothing @@ -40,20 +46,22 @@ (do c <- atomically (readTVar sharedConfig) runWithConfig c ( - do - (monitorConfig configPath sharedConfig wakeSig)))) + monitorConfig configPath sharedConfig wakeSig))) - logInfoIO ("Listening on port " ++ show port) + 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 + (result, config') <- runWithConfig config (do logDebug (show (pathInfo req)) logDebug (show (requestHeaders req)) - dispatchRequest (fromStrict body) req f)) + dispatchRequest (fromStrict body) req f) atomically (writeTVar sharedConfig config') return result @@ -67,7 +75,7 @@ | requestMethod req == "POST" && isJust (soapAction req) = handleSoapAction (fromJust (soapAction req)) body req f -dispatchRequest _ _ _ = error "did not match dispatch" +dispatchRequest _ _ _ = error didNotMatchDispatch getWholeRequestBody :: Request -> IO B.ByteString getWholeRequestBody request = do diff --git a/src/HEyefi/Soap.hs b/src/HEyefi/Soap.hs --- a/src/HEyefi/Soap.hs +++ b/src/HEyefi/Soap.hs @@ -12,6 +12,7 @@ import HEyefi.Log (logInfo, logDebug) import HEyefi.MarkLastPhotoInRoll (markLastPhotoInRollResponse) import HEyefi.StartSession (startSessionResponse) +import HEyefi.Strings import HEyefi.Types (HEyefiM, HEyefiApplication, lastSNonce) @@ -19,7 +20,8 @@ import qualified Data.ByteString.Lazy as BL import Control.Arrow ((>>>)) -import Control.Monad.IO.Class (liftIO) +import Control.Arrow.IOStateListArrow (IOSLA) +import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.State.Lazy (get) import Data.ByteString.Lazy (fromStrict) import Data.ByteString.Lazy.UTF8 (toString) @@ -30,22 +32,28 @@ import Data.Maybe (fromJust) import Data.Time.Clock (getCurrentTime, UTCTime) import Data.Time.Format (formatTime, rfc822DateFormat, defaultTimeLocale) +import Data.Tree.NTree.TypeDefs (NTree) 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 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 - , (/>)) +import Text.XML.HXT.Arrow.XmlState.TypeDefs (XIOState) +import Text.XML.HXT.Core ( + runX + , readString + , getText + , (/>) ) +import Text.XML.HXT.DOM.TypeDefs (XNode, XmlTree) data SoapAction = StartSession @@ -63,7 +71,7 @@ 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") + Just (_,sa) -> error (notADefinedSoapAction (show sa)) _ -> Nothing mkResponse :: String -> HEyefiM Response @@ -87,36 +95,45 @@ , (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)) + handleSoapAction :: SoapAction -> BL.ByteString -> HEyefiApplication handleSoapAction StartSession body _ f = do - logInfo "Got StartSession request" + logDebug gotStartSessionRequest 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" + macaddress <- getTagText xmlDocument "macaddress" + cnonce <- getTagText xmlDocument "cnonce" + transfermode <- getTagText xmlDocument "transfermode" + transfermodetimestamp <- getTagText xmlDocument "transfermodetimestamp" logDebug (show macaddress) logDebug (show transfermodetimestamp) - responseBody <- (startSessionResponse + responseBody <- startSessionResponse (head macaddress) (head cnonce) (head transfermode) - (head transfermodetimestamp)) + (head transfermodetimestamp) logDebug (show responseBody) response <- mkResponse responseBody liftIO (f response) handleSoapAction GetPhotoStatus body _ f = do - logInfo "Got GetPhotoStatus request" + logDebug gotGetPhotoStatusRequest credentialGood <- checkCredential body if credentialGood then do responseBody <- getPhotoStatusResponse response <- mkResponse responseBody liftIO (f response) - else do + else liftIO (f mkUnauthorizedResponse) handleSoapAction MarkLastPhotoInRoll _ _ f = do - logInfo "Got MarkLastPhotoInRoll request" + logDebug gotMarkLastPhotoInRollRequest responseBody <- markLastPhotoInRollResponse response <- mkResponse responseBody liftIO (f response) @@ -125,23 +142,21 @@ 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" + macaddress <- getTagText xmlDocument "macaddress" + credential <- getTagText xmlDocument "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)) + logInfo (noUploadKeyInConfiguration (head macaddress)) return False Just upload_key_0' -> do - let credentialString = (head macaddress) ++ upload_key_0' ++ snonce + 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)) + if head credential /= expectedCredential then do + logInfo (invalidCredential expectedCredential (head credential)) return False else return True diff --git a/src/HEyefi/Strings.hs b/src/HEyefi/Strings.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/Strings.hs @@ -0,0 +1,66 @@ +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" diff --git a/src/HEyefi/Types.hs b/src/HEyefi/Types.hs --- a/src/HEyefi/Types.hs +++ b/src/HEyefi/Types.hs @@ -14,9 +14,18 @@ --Global Monads newtype HEyefiM a = HEyefiM { runHeyefi :: StateT Config IO a - } deriving (Functor, Applicative, Monad, MonadIO, MonadMask, MonadCatch, MonadThrow, MonadState Config) + } deriving ( Functor + , Applicative + , Monad + , MonadIO + , MonadMask + , MonadCatch + , MonadThrow + , MonadState Config) -type HEyefiApplication = Request -> (Response -> IO ResponseReceived) -> HEyefiM ResponseReceived +type HEyefiApplication = Request + -> (Response -> IO ResponseReceived) + -> HEyefiM ResponseReceived -- Logging data LogLevel = Info | Debug diff --git a/src/HEyefi/UploadPhoto.hs b/src/HEyefi/UploadPhoto.hs --- a/src/HEyefi/UploadPhoto.hs +++ b/src/HEyefi/UploadPhoto.hs @@ -27,13 +27,13 @@ , root , writeDocumentToString) -copyMatchingOwnership :: FileStatus -> FilePath -> FilePath -> IO (FilePath) +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 :: FilePath -> FilePath -> IO FilePath changeOwnershipAndCopy uploadDir extractionDir = do s <- getFileStatus uploadDir names <- getDirectoryContents extractionDir @@ -64,13 +64,13 @@ -- 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 :: 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 + handleFile uploadDir filePath handle = withSystemTempDirectory "heyefi_extracted" (handleDir uploadDir filePath handle) handleDir uploadDir tempFile tempFileHandle extractionDir = do BL.hPut tempFileHandle file @@ -84,7 +84,7 @@ let MultiPart bodyParts = parseMultipartBody multipartBodyBoundary body logDebug (show (length bodyParts)) lBP bodyParts - let (BodyPart _ soapEnvelope) = bodyParts !! 0 + let (BodyPart _ soapEnvelope) = head bodyParts let (BodyPart _ file) = bodyParts !! 1 let (BodyPart _ digest) = bodyParts !! 2 @@ -100,7 +100,7 @@ where lBP [] = return () - lBP ((BodyPart headers _):xs) = do + lBP (BodyPart headers _ : xs) = do logDebug (show headers) lBP xs return ()