heyefi 0.1.0.2 → 0.1.1.0
raw patch · 11 files changed
+204/−95 lines, 11 filesdep +optparse-applicative
Dependencies added: optparse-applicative
Files
- heyefi.cabal +5/−1
- src/HEyefi/CommandLineOptions.hs +29/−0
- src/HEyefi/Config.hs +10/−15
- src/HEyefi/Constant.hs +0/−16
- src/HEyefi/Hex.hs +1/−1
- src/HEyefi/Log.hs +2/−3
- src/HEyefi/Main.hs +24/−16
- src/HEyefi/Soap.hs +50/−35
- src/HEyefi/Strings.hs +66/−0
- src/HEyefi/Types.hs +11/−2
- src/HEyefi/UploadPhoto.hs +6/−6
heyefi.cabal view
@@ -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
+ src/HEyefi/CommandLineOptions.hs view
@@ -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
src/HEyefi/Config.hs view
@@ -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- })+ }
src/HEyefi/Constant.hs view
@@ -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`."
src/HEyefi/Hex.hs view
@@ -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
src/HEyefi/Log.hs view
@@ -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 ()
src/HEyefi/Main.hs view
@@ -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
src/HEyefi/Soap.hs view
@@ -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
+ src/HEyefi/Strings.hs view
@@ -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"
src/HEyefi/Types.hs view
@@ -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
src/HEyefi/UploadPhoto.hs view
@@ -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 ()