diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,16 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +For more information, please refer to diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/heyefi.cabal b/heyefi.cabal new file mode 100644 --- /dev/null +++ b/heyefi.cabal @@ -0,0 +1,93 @@ +name: heyefi +version: 0.1.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 +license: PublicDomain +license-file: LICENSE +author: Ryan Mulligan +maintainer: ryan@ryantm.com +category: Network +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/ryantm/heyefi + +executable heyefi + default-language: Haskell2010 + hs-source-dirs: src + main-is: HEyefi/Main.hs + ghc-options: -Wall + build-depends: base >=4 && <=5 + , stm + , unix + , MissingH + , bytestring + , utf8-string + , time + , iso8601-time + , warp + , wai + , HTTP + , http-types + , HandsomeSoup + , hxt + , case-insensitive + , old-locale + , multipart + , tar + , configurator + , unordered-containers + , text + , errors + , temporary + , directory + , filemanip + , filepath + , mtl + , transformers + , exceptions + , random + +test-suite test-heyefi + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test, src + main-is: Spec.hs + ghc-options: -Wall + build-depends: base >=4 && <=5 + , stm + , unix + , containers + , hspec + , MissingH + , bytestring + , utf8-string + , time + , iso8601-time + , warp + , wai + , HTTP + , http-types + , HandsomeSoup + , hxt + , case-insensitive + , old-locale + , multipart + , tar + , configurator + , unordered-containers + , text + , silently + , filepath + , directory + , errors + , temporary + , directory + , filemanip + , mtl + , transformers + , exceptions + , random diff --git a/src/HEyefi/Main.hs b/src/HEyefi/Main.hs new file mode 100644 --- /dev/null +++ b/src/HEyefi/Main.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import HEyefi.Config (monitorConfig, newConfig, runWithConfig) +import HEyefi.Constant (port, configPath) +import HEyefi.Log (logInfoIO, logDebug) +import HEyefi.Soap (handleSoapAction, soapAction) +import HEyefi.Types (SharedConfig, HEyefiApplication) +import HEyefi.UploadPhoto (handleUpload) + + +import Control.Concurrent (forkIO) +import Control.Concurrent.STM (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.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 + wakeSig <- atomically (newTVar Nothing) + sharedConfig <- newConfig + _ <- installHandler sigHUP (Catch $ handleHup wakeSig) Nothing + + _ <- forkIO (forever + (do + c <- atomically (readTVar sharedConfig) + runWithConfig c ( + do + (monitorConfig configPath sharedConfig wakeSig)))) + + logInfoIO ("Listening on port " ++ show port) + run port (app sharedConfig) + +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 "did not match dispatch" + +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/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}