heyefi (empty) → 0.1.0.0
raw patch · 5 files changed
+190/−0 lines, 5 filesdep +HTTPdep +HandsomeSoupdep +MissingHsetup-changed
Dependencies added: HTTP, HandsomeSoup, MissingH, base, bytestring, case-insensitive, configurator, containers, directory, errors, exceptions, filemanip, filepath, hspec, http-types, hxt, iso8601-time, mtl, multipart, old-locale, random, silently, stm, tar, temporary, text, time, transformers, unix, unordered-containers, utf8-string, wai, warp
Files
- LICENSE +16/−0
- Setup.hs +2/−0
- heyefi.cabal +93/−0
- src/HEyefi/Main.hs +78/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -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 <http://unlicense.org/>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ heyefi.cabal view
@@ -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
+ src/HEyefi/Main.hs view
@@ -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)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}