Мыслеформы -

jdevelop — 06.07.2010 забавно, с тайпклассами весьма удобно делать совершенно дикие вещи

ну например вместо того, чтобы передавать в функцию еще пачку функций-трансформаторов, делаешь себе чуток data/newtype, говоришь правильные типы явно в сигнатуре функции или в выражении - и оно самостоятельно работает

а код при этом уменьшается раза так в полтора-два

автоматический деривинг классов - вообще космическая вещь, никакой жабе в упор не снилось

получается такое себе квазиметапрограммирование - достаточно определить операции над типами, и компилятор сделает все остальное по месту пользования

например

newtype Result a = Result { getLJResult :: Either LJError a } deriving (Show)

makeErrorStr ::  String -> Result (Either LJError a)
makeErrorStr = Result . Left . SimpleError

makeError ::  LJError -> Result a
makeError = Result . Left

makeResult :: a -> Result a
makeResult = Result . Right

class ResponseTransformer a b where
    transform :: ParseResult String a -> b

applyResultP :: (ResponseTransformer a b) => Result (ParseResult String a) -> Result b
applyResultP = applyResultP' . getLJResult
    where
        applyResultP' (Left err) = makeError err
        applyResultP' (Right s) = makeResult $ transform s

runRequest :: (ResponseTransformer a b) => LJRequest -> CustomResponseParser String a -> IO ( Result b )
runRequest request responseParser = do
    curl <- CU.initialize
    applyResultP <$> parseResponse _customObjectFactory _customObjectDAO .  extractResponse <$> 
        CU.do_curl_ curl "http://www.livejournal.com/interface/flat" curlOptions
    where
        _customObjectFactory = customObjectFactory responseParser
        _customObjectDAO = customObjectDAO responseParser
        curlOptions = makeRequest request : CU.method_POST
        makeRequest = CurlPostFields . DL.map makeParamNV . params
        makeParamNV (RequestParam name value) = name ++ "=" ++ value

newtype ChalString a = ChalString { getChStr :: a }

instance ResponseTransformer ( ChalString String ) (Maybe String) where
    transform (simpleMap, _, _) = DMP.lookup "challenge" simpleMap
            
prepareChallenge :: String -> IO (Maybe (String, String))
prepareChallenge password = do
    handleResponse <$> (runRequest request (CRP noFactory noUpdate) :: IO (Result (Maybe String)))
    where
        handleResponse src = handleResponse' $ getLJResult src
        handleResponse' (Left err) = Nothing
        handleResponse' (Right res) = makeChallengePair <$> res
        request = makeRequest [("mode","getchallenge")]
        noFactory :: String -> Maybe ( ChalString String )
        noFactory = \_ -> Nothing
        noUpdate = \_ _ _ _ -> Nothing
        makeChallengePair chal = ( chal, hashcode chal )
        md5Pass = MD5.md5sum $ BStr.pack password
        hashcode chal = MD5.md5sum . BStr.pack $ chal ++ md5Pass

по факту расширение формата парсинга делается через определение инстанса ResponseTransformer, навроде как

instance ResponseTransformer LoginResponseData LJLoginResponse where
    transform (simpleMap, enumMap, objectMap) = undefined -- TODO get parts of response from the map

loginExt :: LJLoginRequest -> IO ( Result LJLoginResponse )
loginExt request =
    prepareChallenge ( password request ) >>= DM.maybe emptyResponse login'
    where
        emptyResponse = return ( makeError NoChallenge )
        login' (chal, auth_response) = 
            runRequest request' (CRP loginObjectFactory loginObjectUpdater) :: IO (Result LJLoginResponse)
            where
                params = DL.concat [
                        [
                            ("mode","login"), 
                            ("user",user request), 
                            ("auth_method","challenge"),
                            ("auth_challenge",chal),
                            ("auth_response",auth_response)
                         ],
                         DM.maybe [] ( makeTupleSArr "getmoods" .  show ) ( moods request ),
                         guard (menus request) >> makeTupleSArr "getmenus" "1",
                         guard (pickws request) >> makeTupleSArr "getpickws" "1",
                         guard (pickwurls request) >> makeTupleSArr "getpickwurls" "1"
                         ]
                request' = makeRequest params
                makeTupleSArr = ( return . ) . (,)

в сухом остатке получаем, что основное действие выполняется внутри

runRequest request' (CRP loginObjectFactory loginObjectUpdater) :: IO (Result LJLoginResponse)

где указание IO (Result LJLoginResponse) включает в работу аццкую типодробилку и на выходе применяются правильные тайпклассы к правильным объектам

Оставить комментарий

Популярные посты: